diff options
| -rw-r--r-- | hsm-cam/Hsm/Cam.hs | 3 | ||||
| -rw-r--r-- | hsm-cam/hsm-cam.cabal | 2 | ||||
| -rw-r--r-- | hsm-core/Hsm/Core/Bracket.hs | 23 | ||||
| -rw-r--r-- | hsm-core/hsm-core.cabal | 8 | ||||
| -rw-r--r-- | hsm-gpio/Hsm/GPIO.hs | 12 |
5 files changed, 38 insertions, 10 deletions
diff --git a/hsm-cam/Hsm/Cam.hs b/hsm-cam/Hsm/Cam.hs index c82cdd7..fe17057 100644 --- a/hsm-cam/Hsm/Cam.hs +++ b/hsm-cam/Hsm/Cam.hs @@ -44,6 +44,7 @@ import Hsm.Cam.FFI , stopCamera , stopCameraManager ) +import Hsm.Core.Bracket (bracketConst, bracketLiftIO_) import Hsm.Log (Log, Severity(Attention, Info, Trace), getLevel, logMsg, makeLoggerIO) import MMAP (mapShared, mkMmapFlags, mmap, munmap, protRead) import System.Directory (doesFileExist, removeFile) @@ -127,8 +128,6 @@ runCam action = do . bracketLiftIO_ createRequest (return ()) . bracket mapDmaBuffer unmapDmaBuffer $ \dmaBuffer -> evalStaticRep (Cam Rep {..}) action where - bracketConst alloc dealloc = bracket alloc dealloc . const - bracketLiftIO_ alloc dealloc = bracket_ (liftIO alloc) (liftIO dealloc) loggerAlloc = do logMsg @"cam" Info "Registering FFI logger" loggerIO <- makeLoggerIO @"cam" diff --git a/hsm-cam/hsm-cam.cabal b/hsm-cam/hsm-cam.cabal index 5c06ea7..fe767cb 100644 --- a/hsm-cam/hsm-cam.cabal +++ b/hsm-cam/hsm-cam.cabal @@ -13,6 +13,7 @@ library , directory , effectful-core , effectful-plugin + , hsm-core , hsm-log , JuicyPixels , monad-loops @@ -44,6 +45,7 @@ executable test-cam , directory , effectful-core , effectful-plugin + , hsm-core , hsm-log , JuicyPixels , monad-loops diff --git a/hsm-core/Hsm/Core/Bracket.hs b/hsm-core/Hsm/Core/Bracket.hs new file mode 100644 index 0000000..f666d86 --- /dev/null +++ b/hsm-core/Hsm/Core/Bracket.hs @@ -0,0 +1,23 @@ +-- Resource management combinators for safe acquisition/release patterns. +-- Provides specialized bracket variants for common scenarios. +module Hsm.Core.Bracket + ( bracketConst + , bracketCont + , bracketLiftIO_ + ) where + +import Control.Monad.Trans.Cont (Cont, cont) +import Effectful (Eff, IOE, (:>), liftIO) +import Effectful.Exception (bracket, bracket_) + +-- Ignores allocated resource in the action +bracketConst :: Eff es a -> (a -> Eff es b) -> Eff es c -> Eff es c +bracketConst alloc dealloc = bracket alloc dealloc . const + +-- Continuation-passing style integration +bracketCont :: Eff es a -> (a -> Eff es b) -> Cont (Eff es c) a +bracketCont alloc dealloc = cont $ bracket alloc dealloc + +-- Lifts IO operations into Effectful brackets +bracketLiftIO_ :: IOE :> es => IO a -> IO b -> Eff es c -> Eff es c +bracketLiftIO_ alloc dealloc = bracket_ (liftIO alloc) $ liftIO dealloc diff --git a/hsm-core/hsm-core.cabal b/hsm-core/hsm-core.cabal index 856a359..67a63e2 100644 --- a/hsm-core/hsm-core.cabal +++ b/hsm-core/hsm-core.cabal @@ -3,12 +3,16 @@ author: Paul Oliver <contact@pauloliver.dev> name: hsm-core version: 0.1.0.0 - library build-depends: , base + , effectful-core , template-haskell + , transformers default-language: GHC2024 - exposed-modules: Hsm.Core.Serial + exposed-modules: + Hsm.Core.Bracket + Hsm.Core.Serial + ghc-options: -O2 -Wall -Werror -Wno-star-is-type -Wunused-packages diff --git a/hsm-gpio/Hsm/GPIO.hs b/hsm-gpio/Hsm/GPIO.hs index 0f320a1..8f3115d 100644 --- a/hsm-gpio/Hsm/GPIO.hs +++ b/hsm-gpio/Hsm/GPIO.hs @@ -11,7 +11,7 @@ module Hsm.GPIO ) where import Control.Monad (forM_, void) -import Control.Monad.Trans.Cont (cont, evalCont) +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_) @@ -19,6 +19,7 @@ import Effectful.Exception (bracket) import Foreign.C.String (withCString) 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 @@ -78,7 +79,6 @@ setAllPins lineValue = do 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 - contBracket alloc dealloc = cont $ bracket alloc dealloc chipPath = "/dev/gpiochip0" chipAlloc = do logMsg Info $ "Opening GPIO chip " <> chipPath @@ -118,10 +118,10 @@ runGPIO consumer action = bracket lineRequestAlloc lineRequestDealloc $ \lineReq lineRequestAlloc = do logMsg Info "Allocating line request" evalCont $ do - chip <- contBracket chipAlloc chipDealloc - lineSettings <- contBracket lineSettingsAlloc lineSettingsDealloc - lineConfig <- contBracket (lineConfigAlloc lineSettings) lineConfigDealloc - requestConfig <- contBracket requestConfigAlloc requestConfigDealloc + 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" |