aboutsummaryrefslogtreecommitdiff
path: root/hsm-gpio
diff options
context:
space:
mode:
Diffstat (limited to 'hsm-gpio')
-rw-r--r--hsm-gpio/Hsm/GPIO.hs135
-rw-r--r--hsm-gpio/Hsm/GPIO/FFI.hs95
-rw-r--r--hsm-gpio/Hsm/GPIO/FFI.hsc116
-rw-r--r--hsm-gpio/hsm-gpio.cabal2
4 files changed, 178 insertions, 170 deletions
diff --git a/hsm-gpio/Hsm/GPIO.hs b/hsm-gpio/Hsm/GPIO.hs
index 4786379..31b73d9 100644
--- a/hsm-gpio/Hsm/GPIO.hs
+++ b/hsm-gpio/Hsm/GPIO.hs
@@ -3,22 +3,24 @@
{-# LANGUAGE TypeFamilies #-}
module Hsm.GPIO
- ( GPIOPin(..)
+ ( GPIOPin (..)
, GPIO
, setPins
, setAllPins
, runGPIO
- ) where
+ )
+where
import Control.Monad (forM_, void)
+import Control.Monad.Trans.Cont (evalCont)
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 (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>))
+import Effectful.Dispatch.Static (SideEffects (WithSideEffects), StaticRep, evalStaticRep, getStaticRep, unsafeEff_)
import Effectful.Exception (bracket)
-import Effectful.Resource (Resource, allocateEff, releaseEff)
import Foreign.C.String (withCString)
-import Foreign.C.Types (CSize(CSize), CUInt)
+import Foreign.C.Types (CSize (CSize), CUInt)
import Foreign.Ptr (Ptr)
+import Hsm.Core.Bracket (bracketCont)
import Hsm.Core.Serial (makeSerial)
import Hsm.GPIO.FFI
( LineRequest
@@ -42,7 +44,7 @@ import Hsm.GPIO.FFI
, requestConfigNew
, requestConfigSetConsumer
)
-import Hsm.Log (Log, Severity(Info, Trace), logMsg)
+import Hsm.Log (Log, Severity (Info, Trace), logMsg)
import Prelude hiding (replicate)
$(makeSerial "GPIO" "Pin" "pinLine" ''CUInt $ [2 .. 17] <> [20 .. 27])
@@ -60,14 +62,14 @@ data GPIO (a :: * -> *) (b :: *)
type instance DispatchOf GPIO = Static WithSideEffects
-newtype instance StaticRep GPIO =
- GPIO (Ptr LineRequest)
+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
+ unsafeEff_ . forM_ pins $ \pin -> lineRequestSetValue lineRequest (pinLine pin) lineValue
setAllPins :: (GPIO :> es, Log "gpio" :> es) => LineValue -> Eff es ()
setAllPins lineValue = do
@@ -75,68 +77,53 @@ setAllPins lineValue = do
logMsg Trace $ "Setting all pins " <> show allPins <> " to " <> show lineValue
unsafeEff_ . unsafeWith (replicate pinCount lineValue) $ void . lineRequestSetValues 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
- lineRequestBracket chip requestConfig lineConfig $ \lineRequest -> do
- releaseEff requestConfigKey
- releaseEff lineConfigKey
- releaseEff lineSettingsKey
- releaseEff chipKey
- evalStaticRep (GPIO lineRequest) action
+runGPIO :: (IOE :> es, Log "gpio" :> es) => String -> Eff (GPIO : es) a -> Eff es a
+runGPIO consumer action = bracket lineRequestAlloc lineRequestDealloc $ \lineRequest -> evalStaticRep (GPIO lineRequest) action
where
- 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 pinCount) lineSettings
- 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 = bracket 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
+ 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
+ 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
+ lineConfigAlloc lineSettings = 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 pinCount) lineSettings
+ return lineConfig
+ lineConfigDealloc lineConfig = do
+ logMsg Info "Freeing line config"
+ liftIO $ lineConfigFree lineConfig
+ 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
+ lineRequestAlloc = do
+ logMsg Info "Allocating line request"
+ evalCont $ do
+ chip <- bracketCont chipAlloc chipDealloc
+ lineSettings <- bracketCont lineSettingsAlloc lineSettingsDealloc
+ lineConfig <- bracketCont (lineConfigAlloc lineSettings) lineConfigDealloc
+ requestConfig <- bracketCont requestConfigAlloc requestConfigDealloc
+ return . liftIO $ chipRequestLines chip requestConfig lineConfig
+ lineRequestDealloc lineRequest = do
+ logMsg Info "Releasing line request"
+ liftIO $ lineRequestRelease lineRequest
diff --git a/hsm-gpio/Hsm/GPIO/FFI.hs b/hsm-gpio/Hsm/GPIO/FFI.hs
deleted file mode 100644
index e0d6d07..0000000
--- a/hsm-gpio/Hsm/GPIO/FFI.hs
+++ /dev/null
@@ -1,95 +0,0 @@
-{-# LANGUAGE CApiFFI #-}
-
--- FFI bindings to `libgpiod` for direct GPIO hardware access.
---
--- Exposes only the minimal required subset of `libgpiod` functionality used by
--- this project. The bindings are suitable for low-level hardware control.
---
--- Future work could expand this into a comprehensive `gpiod` binding package.
-module Hsm.GPIO.FFI
- ( chipOpen
- , chipClose
- , input
- , output
- , LineValue
- , active
- , inactive
- , lineSettingsNew
- , lineSettingsFree
- , lineSettingsSetDirection
- , lineSettingsSetOutputValue
- , lineConfigNew
- , lineConfigFree
- , lineConfigAddLineSettings
- , requestConfigNew
- , requestConfigFree
- , requestConfigSetConsumer
- , LineRequest
- , chipRequestLines
- , lineRequestRelease
- , lineRequestSetValue
- , lineRequestSetValues
- ) where
-
-import Foreign.C.String (CString)
-import Foreign.C.Types (CInt(CInt), CSize(CSize), CUInt(CUInt))
-import Foreign.Ptr (Ptr)
-import Foreign.Storable (Storable)
-
-data Chip
-
-foreign import ccall unsafe "gpiod.h gpiod_chip_open" chipOpen :: CString -> IO (Ptr Chip)
-
-foreign import ccall unsafe "gpiod.h gpiod_chip_close" chipClose :: Ptr Chip -> IO ()
-
-data LineSettings
-
-newtype LineDirection =
- LineDirection CInt
- deriving (Show)
-
-foreign import capi unsafe "gpiod.h value GPIOD_LINE_DIRECTION_INPUT" input :: LineDirection
-
-foreign import capi unsafe "gpiod.h value GPIOD_LINE_DIRECTION_OUTPUT" output :: LineDirection
-
-newtype LineValue =
- LineValue CInt
- deriving (Show, Storable)
-
-foreign import capi unsafe "gpiod.h value GPIOD_LINE_VALUE_ACTIVE" active :: LineValue
-
-foreign import capi unsafe "gpiod.h value GPIOD_LINE_VALUE_INACTIVE" inactive :: LineValue
-
-foreign import ccall unsafe "gpiod.h gpiod_line_settings_new" lineSettingsNew :: IO (Ptr LineSettings)
-
-foreign import ccall unsafe "gpiod.h gpiod_line_settings_free" lineSettingsFree :: Ptr LineSettings -> IO ()
-
-foreign import ccall unsafe "gpiod.h gpiod_line_settings_set_direction" lineSettingsSetDirection :: Ptr LineSettings -> LineDirection -> IO CInt
-
-foreign import ccall unsafe "gpiod.h gpiod_line_settings_set_output_value" lineSettingsSetOutputValue :: Ptr LineSettings -> LineValue -> IO CInt
-
-data LineConfig
-
-foreign import ccall unsafe "gpiod.h gpiod_line_config_new" lineConfigNew :: IO (Ptr LineConfig)
-
-foreign import ccall unsafe "gpiod.h gpiod_line_config_free" lineConfigFree :: Ptr LineConfig -> IO ()
-
-foreign import ccall unsafe "gpiod.h gpiod_line_config_add_line_settings" lineConfigAddLineSettings :: Ptr LineConfig -> Ptr CUInt -> CSize -> Ptr LineSettings -> IO CInt
-
-data RequestConfig
-
-foreign import ccall unsafe "gpiod.h gpiod_request_config_new" requestConfigNew :: IO (Ptr RequestConfig)
-
-foreign import ccall unsafe "gpiod.h gpiod_request_config_free" requestConfigFree :: Ptr RequestConfig -> IO ()
-
-foreign import ccall unsafe "gpiod.h gpiod_request_config_set_consumer" requestConfigSetConsumer :: Ptr RequestConfig -> CString -> IO ()
-
-data LineRequest
-
-foreign import ccall unsafe "gpiod.h gpiod_chip_request_lines" chipRequestLines :: Ptr Chip -> Ptr RequestConfig -> Ptr LineConfig -> IO (Ptr LineRequest)
-
-foreign import ccall unsafe "gpiod.h gpiod_line_request_release" lineRequestRelease :: Ptr LineRequest -> IO ()
-
-foreign import ccall unsafe "gpiod.h gpiod_line_request_set_value" lineRequestSetValue :: Ptr LineRequest -> CUInt -> LineValue -> IO CInt
-
-foreign import ccall unsafe "gpiod.h gpiod_line_request_set_values" lineRequestSetValues :: Ptr LineRequest -> Ptr LineValue -> IO CInt
diff --git a/hsm-gpio/Hsm/GPIO/FFI.hsc b/hsm-gpio/Hsm/GPIO/FFI.hsc
new file mode 100644
index 0000000..d8b0f47
--- /dev/null
+++ b/hsm-gpio/Hsm/GPIO/FFI.hsc
@@ -0,0 +1,116 @@
+{-# LANGUAGE CApiFFI #-}
+
+-- FFI bindings to `libgpiod` for direct GPIO hardware access.
+--
+-- Exposes only the minimal required subset of `libgpiod` functionality used by
+-- this project. The bindings are suitable for low-level hardware control.
+--
+-- Future work could expand this into a comprehensive `gpiod` binding package.
+module Hsm.GPIO.FFI
+ ( chipOpen
+ , chipClose
+ , input
+ , output
+ , LineValue
+ , active
+ , inactive
+ , lineSettingsNew
+ , lineSettingsFree
+ , lineSettingsSetDirection
+ , lineSettingsSetOutputValue
+ , lineConfigNew
+ , lineConfigFree
+ , lineConfigAddLineSettings
+ , requestConfigNew
+ , requestConfigFree
+ , requestConfigSetConsumer
+ , LineRequest
+ , chipRequestLines
+ , lineRequestRelease
+ , lineRequestSetValue
+ , lineRequestSetValues
+ )
+where
+
+import Foreign.C.String (CString)
+import Foreign.C.Types (CInt (CInt), CSize (CSize), CUInt (CUInt))
+import Foreign.Ptr (Ptr)
+import Foreign.Storable (Storable)
+
+data Chip
+
+foreign import capi safe "gpiod.h gpiod_chip_open"
+ chipOpen :: CString -> IO (Ptr Chip)
+
+foreign import capi safe "gpiod.h gpiod_chip_close"
+ chipClose :: Ptr Chip -> IO ()
+
+data LineSettings
+
+newtype LineDirection
+ = LineDirection CInt
+ deriving Show
+
+foreign import capi safe "gpiod.h value GPIOD_LINE_DIRECTION_INPUT"
+ input :: LineDirection
+
+foreign import capi safe "gpiod.h value GPIOD_LINE_DIRECTION_OUTPUT"
+ output :: LineDirection
+
+newtype LineValue
+ = LineValue CInt
+ deriving (Show, Storable)
+
+foreign import capi safe "gpiod.h value GPIOD_LINE_VALUE_ACTIVE"
+ active :: LineValue
+
+foreign import capi safe "gpiod.h value GPIOD_LINE_VALUE_INACTIVE"
+ inactive :: LineValue
+
+foreign import capi safe "gpiod.h gpiod_line_settings_new"
+ lineSettingsNew :: IO (Ptr LineSettings)
+
+foreign import capi safe "gpiod.h gpiod_line_settings_free"
+ lineSettingsFree :: Ptr LineSettings -> IO ()
+
+foreign import capi safe "gpiod.h gpiod_line_settings_set_direction"
+ lineSettingsSetDirection :: Ptr LineSettings -> LineDirection -> IO CInt
+
+foreign import capi safe "gpiod.h gpiod_line_settings_set_output_value"
+ lineSettingsSetOutputValue :: Ptr LineSettings -> LineValue -> IO CInt
+
+data LineConfig
+
+foreign import capi safe "gpiod.h gpiod_line_config_new"
+ lineConfigNew :: IO (Ptr LineConfig)
+
+foreign import capi safe "gpiod.h gpiod_line_config_free"
+ lineConfigFree :: Ptr LineConfig -> IO ()
+
+foreign import capi safe "gpiod.h gpiod_line_config_add_line_settings"
+ lineConfigAddLineSettings :: Ptr LineConfig -> Ptr CUInt -> CSize -> Ptr LineSettings -> IO CInt
+
+data RequestConfig
+
+foreign import capi safe "gpiod.h gpiod_request_config_new"
+ requestConfigNew :: IO (Ptr RequestConfig)
+
+foreign import capi safe "gpiod.h gpiod_request_config_free"
+ requestConfigFree :: Ptr RequestConfig -> IO ()
+
+foreign import capi safe "gpiod.h gpiod_request_config_set_consumer"
+ requestConfigSetConsumer :: Ptr RequestConfig -> CString -> IO ()
+
+data LineRequest
+
+foreign import capi safe "gpiod.h gpiod_chip_request_lines"
+ chipRequestLines :: Ptr Chip -> Ptr RequestConfig -> Ptr LineConfig -> IO (Ptr LineRequest)
+
+foreign import capi safe "gpiod.h gpiod_line_request_release"
+ lineRequestRelease :: Ptr LineRequest -> IO ()
+
+foreign import capi safe "gpiod.h gpiod_line_request_set_value"
+ lineRequestSetValue :: Ptr LineRequest -> CUInt -> LineValue -> IO CInt
+
+foreign import capi safe "gpiod.h gpiod_line_request_set_values"
+ lineRequestSetValues :: Ptr LineRequest -> Ptr LineValue -> IO CInt
diff --git a/hsm-gpio/hsm-gpio.cabal b/hsm-gpio/hsm-gpio.cabal
index a56a67a..ba538db 100644
--- a/hsm-gpio/hsm-gpio.cabal
+++ b/hsm-gpio/hsm-gpio.cabal
@@ -10,7 +10,7 @@ library
, effectful-plugin
, hsm-core
, hsm-log
- , resourcet-effectful
+ , transformers
, vector
default-language: GHC2024
powered by cgit v1.2.1, back to main portfolio site