diff options
Diffstat (limited to 'hsm-gpio/Hsm/GPIO.hs')
| -rw-r--r-- | hsm-gpio/Hsm/GPIO.hs | 284 |
1 files changed, 141 insertions, 143 deletions
diff --git a/hsm-gpio/Hsm/GPIO.hs b/hsm-gpio/Hsm/GPIO.hs index dd69122..2bcf3ed 100644 --- a/hsm-gpio/Hsm/GPIO.hs +++ b/hsm-gpio/Hsm/GPIO.hs @@ -1,163 +1,161 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} module Hsm.GPIO - ( G.active - , G.inactive - , G.LineRequest - , GPIO(..) + ( GPIOPin (..) + , GPIO , setPins , setAllPins - , allocateGPIO - ) where + , runGPIO + ) +where -import Control.IO.Region (Region, alloc, alloc_, defer, free) import Control.Monad (forM_, void) -import Data.ByteString (useAsCString) -import Data.Text (Text, pack) -import Data.Text.Encoding (encodeUtf8) -import Data.Vector.Storable qualified as V -import Foreign.C.Types (CSize(CSize), CUInt(CUInt)) +import Data.Vector.Storable (fromList, replicate, unsafeWith) +import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>)) +import Effectful.Dispatch.Static + ( SideEffects (WithSideEffects) + , StaticRep + , evalStaticRep + , getStaticRep + , unsafeEff_ + ) +import Effectful.Resource (Resource, allocateEff, releaseEff) +import Foreign.C.String (withCString) +import Foreign.C.Types (CSize (CSize), CUInt) import Foreign.Ptr (Ptr) -import Hsm.GPIO.Lib qualified as G -import Hsm.Log qualified as L +import Hsm.Core.Serial (makeSerial) +import Hsm.GPIO.FFI + ( LineRequest + , LineValue + , chipClose + , chipOpen + , chipRequestLines + , inactive + , lineConfigAddLineSettings + , lineConfigFree + , lineConfigNew + , lineRequestRelease + , lineRequestSetValue + , lineRequestSetValues + , lineSettingsFree + , lineSettingsNew + , lineSettingsSetDirection + , lineSettingsSetOutputValue + , output + , requestConfigFree + , requestConfigNew + , requestConfigSetConsumer + ) +import Hsm.Log (Log, Severity (Info, Trace), logMsg) +import Prelude hiding (replicate) -logMsg :: Text -> IO () -logMsg = L.logMsg ["gpio"] +$(makeSerial "GPIO" "Pin" "pinLine" ''CUInt $ [2 .. 17] <> [20 .. 27]) -data GPIO - = GPIO2 - | GPIO3 - | GPIO4 - | GPIO5 - | GPIO6 - | GPIO7 - | GPIO8 - | GPIO9 - | GPIO10 - | GPIO11 - | GPIO12 - | GPIO13 - | GPIO14 - | GPIO15 - | GPIO16 - | GPIO17 - -- | GPIO18 -- reserved for PWM - -- | GPIO19 -- reserved for PWM - | GPIO20 - | GPIO21 - | GPIO22 - | GPIO23 - | GPIO24 - | GPIO25 - | GPIO26 - | GPIO27 - deriving (Bounded, Enum, Show) - -pinLine :: GPIO -> CUInt -pinLine = CUInt . read . drop 4 . show - -allPins :: [GPIO] +allPins :: [GPIOPin] allPins = [minBound .. maxBound] allLines :: [CUInt] allLines = pinLine <$> allPins -setPins :: Ptr G.LineRequest -> [GPIO] -> G.LineValue -> IO () -setPins lineRequest pins lineValue = do - logMsg - $ "Setting pin(s) " - <> pack (show pins) - <> " to state " - <> pack (show lineValue) - forM_ pins $ \pin -> G.lineRequestSetValue lineRequest (pinLine pin) lineValue +pinCount :: Int +pinCount = length allPins + +data GPIO (a :: * -> *) (b :: *) + +type instance DispatchOf GPIO = Static WithSideEffects + +newtype instance StaticRep GPIO + = GPIO (Ptr LineRequest) + +setPins :: (GPIO :> es, Log "gpio" :> es) => [GPIOPin] -> LineValue -> Eff es () +setPins pins lineValue = do + GPIO lineRequest <- getStaticRep + logMsg Trace $ "Setting pin(s) " <> show pins <> " to " <> show lineValue + forM_ pins $ \pin -> + unsafeEff_ $ lineRequestSetValue lineRequest (pinLine pin) lineValue -setAllPins :: Ptr G.LineRequest -> G.LineValue -> IO () -setAllPins lineRequest lineValue = do - logMsg - $ "Setting all pins " - <> pack (show allPins) - <> " to state " - <> pack (show lineValue) - void - $ V.unsafeWith (V.replicate (length allPins) lineValue) - $ G.lineRequestSetValues lineRequest +setAllPins :: (GPIO :> es, Log "gpio" :> es) => LineValue -> Eff es () +setAllPins lineValue = do + GPIO lineRequest <- getStaticRep + logMsg Trace $ "Setting all pins " <> show allPins <> " to " <> show lineValue + unsafeEff_ . unsafeWith (replicate pinCount lineValue) $ + void . lineRequestSetValues lineRequest -allocateGPIO :: Region -> Text -> IO (Ptr G.LineRequest) -allocateGPIO region consumer = do - (chip, chipKey) <- allocateChip - (lineSettings, lineSettingsKey) <- allocateLineSettings - (lineConfig, lineConfigKey) <- allocateLineConfig lineSettings - (requestConfig, requestConfigKey) <- allocateRequestConfig - lineRequest <- allocateLineRequest chip requestConfig lineConfig - free requestConfigKey - free lineConfigKey - free lineSettingsKey - free chipKey - defer region $ setAllPins lineRequest G.inactive - return lineRequest +runGPIO + :: (IOE :> es, Log "gpio" :> es, Resource :> es) + => String + -> Eff (GPIO : es) a + -> Eff es a +runGPIO consumer action = do + (chipKey, chip) <- chipBracket + (lineSettingsKey, lineSettings) <- lineSettingsBracket + (lineConfigKey, lineConfig) <- lineConfigBracket lineSettings + (requestConfigKey, requestConfig) <- requestConfigBracket + (_, lineRequest) <- lineRequestBracket chip requestConfig lineConfig + releaseEff requestConfigKey + releaseEff lineConfigKey + releaseEff lineSettingsKey + releaseEff chipKey + evalStaticRep (GPIO lineRequest) action where - chipPath = "/dev/gpiochip0" - -- GPIO chip - chipOpen = do - logMsg $ "Opening GPIO chip " <> chipPath - useAsCString (encodeUtf8 chipPath) G.chipOpen - chipClose chip = do - logMsg $ "Closing GPIO chip " <> chipPath - G.chipClose chip - allocateChip = alloc region chipOpen chipClose - -- Line settings - lineSettingsNew = do - logMsg "Allocating line settings" - lineSettings <- G.lineSettingsNew - logMsg $ "With direction set to " <> pack (show G.output) - void $ G.lineSettingsSetDirection lineSettings G.output - logMsg $ "With output set to " <> pack (show G.inactive) - void $ G.lineSettingsSetOutputValue lineSettings G.inactive - return lineSettings - lineSettingsFree lineSettings = do - logMsg "Freeing line settings" - G.lineSettingsFree lineSettings - allocateLineSettings = alloc region lineSettingsNew lineSettingsFree - -- Line config - lineConfigNew lineSettings = do - logMsg "Allocating line config" - logMsg $ "With GPIO pins " <> pack (show allPins) - lineConfig <- G.lineConfigNew - void - $ V.unsafeWith (V.fromList allLines) - $ \pinsVector -> - G.lineConfigAddLineSettings + chipBracket = allocateEff chipAlloc chipDealloc + where + chipPath = "/dev/gpiochip0" + chipAlloc = do + logMsg Info $ "Opening GPIO chip " <> chipPath + liftIO $ withCString chipPath chipOpen + chipDealloc chip = do + logMsg Info $ "Closing GPIO chip " <> chipPath + liftIO $ chipClose chip + lineSettingsBracket = allocateEff lineSettingsAlloc lineSettingsDealloc + where + lineSettingsAlloc = do + logMsg Info "Allocating line settings" + lineSettings <- liftIO lineSettingsNew + logMsg Info $ "With direction set to " <> show output + liftIO . void $ lineSettingsSetDirection lineSettings output + logMsg Info $ "With output set to " <> show inactive + liftIO . void $ lineSettingsSetOutputValue lineSettings inactive + return lineSettings + lineSettingsDealloc lineSettings = do + logMsg Info "Freeing line settings" + liftIO $ lineSettingsFree lineSettings + lineConfigBracket lineSettings = + allocateEff lineConfigAlloc lineConfigDealloc + where + lineConfigAlloc = do + logMsg Info "Allocating line config" + logMsg Info $ "With GPIO pins " <> show allPins + lineConfig <- liftIO lineConfigNew + liftIO . void . unsafeWith (fromList allLines) $ \pinsVector -> + lineConfigAddLineSettings lineConfig pinsVector - (CSize $ fromIntegral $ length allPins) + (CSize $ fromIntegral pinCount) lineSettings - return lineConfig - lineConfigFree lineConfig = do - logMsg "Freeing line config" - G.lineConfigFree lineConfig - allocateLineConfig lineSettings = - alloc region (lineConfigNew lineSettings) lineConfigFree - -- Request config - requestConfigNew = do - logMsg "Allocating request config" - logMsg $ "With consumer " <> consumer - requestConfig <- G.requestConfigNew - useAsCString (encodeUtf8 consumer) - $ G.requestConfigSetConsumer requestConfig - return requestConfig - requestConfigFree requestConfig = do - logMsg "Freeing request config" - G.requestConfigFree requestConfig - allocateRequestConfig = alloc region requestConfigNew requestConfigFree - -- Line request - requestLines chip requestConfig lineConfig = do - logMsg "Allocating line request" - G.requestLines chip requestConfig lineConfig - lineRequestRelease lineRequest = do - logMsg "Releasing line request" - G.lineRequestRelease lineRequest - allocateLineRequest chip requestConfig lineConfig = - alloc_ - region - (requestLines chip requestConfig lineConfig) - lineRequestRelease + return lineConfig + lineConfigDealloc lineConfig = do + logMsg Info "Freeing line config" + liftIO $ lineConfigFree lineConfig + requestConfigBracket = allocateEff requestConfigAlloc requestConfigDealloc + where + requestConfigAlloc = do + logMsg Info "Allocating request config" + logMsg Info $ "With consumer " <> consumer + requestConfig <- liftIO requestConfigNew + liftIO . withCString consumer $ requestConfigSetConsumer requestConfig + return requestConfig + requestConfigDealloc requestConfig = do + logMsg Info "Freeing request config" + liftIO $ requestConfigFree requestConfig + lineRequestBracket chip requestConfig lineConfig = + allocateEff lineRequestAlloc lineRequestDealloc + where + lineRequestAlloc = do + logMsg Info "Allocating line request" + liftIO $ chipRequestLines chip requestConfig lineConfig + lineRequestDealloc lineRequest = do + logMsg Info "Releasing line request" + liftIO $ lineRequestRelease lineRequest |