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
130
131
132
133
134
135
136
137
138
139
|
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Hsm.GPIO
( active
, inactive
, GPIOPin (..)
, GPIO
, setPins
, setAllPins
, runGPIO
)
where
import Control.Monad (forM_, void)
import Control.Monad.Trans.Cont (evalCont)
import Data.Proxy (Proxy (Proxy))
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, finally)
import Foreign.C.String (withCString)
import Foreign.C.Types (CSize (CSize), CUInt)
import Foreign.Ptr (Ptr)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Hsm.Core.Bracket (bracketCont)
import Hsm.Core.Serial (makeSerial)
import Hsm.GPIO.FFI
( LineRequest
, LineValue
, active
, 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
:: forall c es a
. (IOE :> es, KnownSymbol c, Log "gpio" :> es)
=> Eff (GPIO : es) a
-> Eff es a
runGPIO action = bracket lineRequestAlloc lineRequestDealloc $ \lineRequest -> evalStaticRep (GPIO lineRequest) . finally action $ setAllPins inactive
where
consumer = symbolVal $ Proxy @c
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
|
