1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Hsm.GPIO
( GPIOPin (..)
, GPIO
, setPins
, setAllPins
, runGPIO
)
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.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
, 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)
$(makeSerial "GPIO" "Pin" "pinLine" ''CUInt $ [2 .. 17] <> [20 .. 27])
allPins :: [GPIOPin]
allPins = [minBound .. maxBound]
allLines :: [CUInt]
allLines = pinLine <$> allPins
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
unsafeEff_ . forM_ pins $ \pin -> lineRequestSetValue lineRequest (pinLine pin) lineValue
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
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
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
|
