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
140
141
142
|
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Hsm.GPIO
( GPIOPin(..)
, GPIO
, setPins
, setAllPins
, runGPIO
) where
import Control.Monad (forM_, void)
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)
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
forM_ pins $ \pin -> unsafeEff_ $ 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, 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
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
|
