Eliminates `resourcet-effectful` dependency of `hsm-gpio`

1 files changed, 51 insertions, 65 deletions

diff --git a/hsm-gpio/Hsm/GPIO.hs b/hsm-gpio/Hsm/GPIO.hs
index 4786379..0f320a1 100644
--- a/hsm-gpio/Hsm/GPIO.hs
+++ b/hsm-gpio/Hsm/GPIO.hs
@@ -11,11 +11,11 @@ module Hsm.GPIO
   ) where
 
 import Control.Monad (forM_, void)
+import Control.Monad.Trans.Cont (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.Exception (bracket)
-import Effectful.Resource (Resource, allocateEff, releaseEff)
 import Foreign.C.String (withCString)
 import Foreign.C.Types (CSize(CSize), CUInt)
 import Foreign.Ptr (Ptr)
@@ -75,68 +75,54 @@ 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
+    contBracket alloc dealloc = cont $ bracket alloc dealloc
+    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 <- contBracket chipAlloc chipDealloc
+        lineSettings <- contBracket lineSettingsAlloc lineSettingsDealloc
+        lineConfig <- contBracket (lineConfigAlloc lineSettings) lineConfigDealloc
+        requestConfig <- contBracket requestConfigAlloc requestConfigDealloc
+        return . liftIO $ chipRequestLines chip requestConfig lineConfig
+    lineRequestDealloc lineRequest = do
+      logMsg Info "Releasing line request"
+      liftIO $ lineRequestRelease lineRequest