aboutsummaryrefslogtreecommitdiff
path: root/hsm-gpio/Hsm
diff options
context:
space:
mode:
Diffstat (limited to 'hsm-gpio/Hsm')
-rw-r--r--hsm-gpio/Hsm/GPIO.hs284
-rw-r--r--hsm-gpio/Hsm/GPIO/FFI.hsc116
-rw-r--r--hsm-gpio/Hsm/GPIO/Lib.hsc116
3 files changed, 257 insertions, 259 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
diff --git a/hsm-gpio/Hsm/GPIO/FFI.hsc b/hsm-gpio/Hsm/GPIO/FFI.hsc
new file mode 100644
index 0000000..f0f5737
--- /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 unsafe "gpiod.h gpiod_chip_open"
+ chipOpen :: CString -> IO (Ptr Chip)
+
+foreign import capi unsafe "gpiod.h gpiod_chip_close"
+ chipClose :: Ptr Chip -> IO ()
+
+data LineSettings
+
+newtype LineDirection
+ = LineDirection CInt
+ deriving Show
+
+foreign import capi "gpiod.h value GPIOD_LINE_DIRECTION_INPUT"
+ input :: LineDirection
+
+foreign import capi "gpiod.h value GPIOD_LINE_DIRECTION_OUTPUT"
+ output :: LineDirection
+
+newtype LineValue
+ = LineValue CInt
+ deriving (Show, Storable)
+
+foreign import capi "gpiod.h value GPIOD_LINE_VALUE_ACTIVE"
+ active :: LineValue
+
+foreign import capi "gpiod.h value GPIOD_LINE_VALUE_INACTIVE"
+ inactive :: LineValue
+
+foreign import capi unsafe "gpiod.h gpiod_line_settings_new"
+ lineSettingsNew :: IO (Ptr LineSettings)
+
+foreign import capi unsafe "gpiod.h gpiod_line_settings_free"
+ lineSettingsFree :: Ptr LineSettings -> IO ()
+
+foreign import capi unsafe "gpiod.h gpiod_line_settings_set_direction"
+ lineSettingsSetDirection :: Ptr LineSettings -> LineDirection -> IO CInt
+
+foreign import capi unsafe "gpiod.h gpiod_line_settings_set_output_value"
+ lineSettingsSetOutputValue :: Ptr LineSettings -> LineValue -> IO CInt
+
+data LineConfig
+
+foreign import capi unsafe "gpiod.h gpiod_line_config_new"
+ lineConfigNew :: IO (Ptr LineConfig)
+
+foreign import capi unsafe "gpiod.h gpiod_line_config_free"
+ lineConfigFree :: Ptr LineConfig -> IO ()
+
+foreign import capi unsafe "gpiod.h gpiod_line_config_add_line_settings"
+ lineConfigAddLineSettings :: Ptr LineConfig -> Ptr CUInt -> CSize -> Ptr LineSettings -> IO CInt
+
+data RequestConfig
+
+foreign import capi unsafe "gpiod.h gpiod_request_config_new"
+ requestConfigNew :: IO (Ptr RequestConfig)
+
+foreign import capi unsafe "gpiod.h gpiod_request_config_free"
+ requestConfigFree :: Ptr RequestConfig -> IO ()
+
+foreign import capi unsafe "gpiod.h gpiod_request_config_set_consumer"
+ requestConfigSetConsumer :: Ptr RequestConfig -> CString -> IO ()
+
+data LineRequest
+
+foreign import capi unsafe "gpiod.h gpiod_chip_request_lines"
+ chipRequestLines :: Ptr Chip -> Ptr RequestConfig -> Ptr LineConfig -> IO (Ptr LineRequest)
+
+foreign import capi unsafe "gpiod.h gpiod_line_request_release"
+ lineRequestRelease :: Ptr LineRequest -> IO ()
+
+foreign import capi unsafe "gpiod.h gpiod_line_request_set_value"
+ lineRequestSetValue :: Ptr LineRequest -> CUInt -> LineValue -> IO CInt
+
+foreign import capi unsafe "gpiod.h gpiod_line_request_set_values"
+ lineRequestSetValues :: Ptr LineRequest -> Ptr LineValue -> IO CInt
diff --git a/hsm-gpio/Hsm/GPIO/Lib.hsc b/hsm-gpio/Hsm/GPIO/Lib.hsc
deleted file mode 100644
index 6716f3a..0000000
--- a/hsm-gpio/Hsm/GPIO/Lib.hsc
+++ /dev/null
@@ -1,116 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ForeignFunctionInterface #-}
-
--- This module provides C bindings to the `gpiod` library for direct GPIO pin
--- control. It includes bindings only for the C functions that are currently
--- used. In the future, creating a complete set of bindings for the entire
--- `gpiod` library as an external package would be a valuable contribution to
--- Hackage.
-
-module Hsm.GPIO.Lib
- ( chipOpen
- , chipClose
- , input
- , output
- , LineValue
- , active
- , inactive
- , lineSettingsNew
- , lineSettingsFree
- , lineSettingsSetDirection
- , lineSettingsSetOutputValue
- , lineConfigNew
- , lineConfigFree
- , lineConfigAddLineSettings
- , requestConfigNew
- , requestConfigFree
- , requestConfigSetConsumer
- , requestLines
- , LineRequest
- , lineRequestRelease
- , lineRequestSetValue
- , lineRequestSetValues
- ) where
-
-#include <gpiod.h>
-
-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)
-
-#{enum LineDirection, LineDirection
- , input = GPIOD_LINE_DIRECTION_INPUT
- , output = GPIOD_LINE_DIRECTION_OUTPUT
-}
-
-newtype LineValue =
- LineValue CInt
- deriving (Show, Storable)
-
-#{enum LineValue, LineValue
- , active = GPIOD_LINE_VALUE_ACTIVE
- , inactive = GPIOD_LINE_VALUE_INACTIVE
-}
-
-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.d 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"
- requestLines :: 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
powered by cgit v1.2.1, back to main portfolio site