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
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
{-# LANGUAGE OverloadedStrings #-}
module Hsm.GPIO
( G.active
, G.inactive
, G.LineRequest
, GPIO(..)
, setPins
, setAllPins
, allocateGPIO
) where
import Control.IO.Region (Region, alloc, alloc_, defer, free)
import Control.Monad (forM_, void)
import Data.ByteString (useAsCString)
import Data.Text (Text, pack)
import Data.Text.Encoding (encodeUtf8)
import Data.Vector.Storable qualified as V
import Foreign.C.Types (CSize(CSize), CUInt(CUInt))
import Foreign.Ptr (Ptr)
import Hsm.GPIO.Lib qualified as G
import Hsm.Log qualified as L
logMsg :: Text -> IO ()
logMsg = L.logMsg ["gpio"]
data GPIO
= GPIO2
| GPIO3
| GPIO4
| GPIO5
| GPIO6
| GPIO7
| GPIO8
| GPIO9
| GPIO10
| GPIO11
| GPIO12
| GPIO13
| GPIO14
| GPIO15
| GPIO16
| GPIO17
-- | GPIO18 -- reserved for PWM
-- | GPIO19 -- reserved for PWM
| GPIO20
| GPIO21
| GPIO22
| GPIO23
| GPIO24
| GPIO25
| GPIO26
| GPIO27
deriving (Bounded, Enum, Show)
pinLine :: GPIO -> CUInt
pinLine = CUInt . read . drop 4 . show
allPins :: [GPIO]
allPins = [minBound .. maxBound]
allLines :: [CUInt]
allLines = pinLine <$> allPins
setPins :: Ptr G.LineRequest -> [GPIO] -> G.LineValue -> IO ()
setPins lineRequest pins lineValue = do
logMsg
$ "Setting pin(s) "
<> pack (show pins)
<> " to state "
<> pack (show lineValue)
forM_ pins $ \pin -> G.lineRequestSetValue lineRequest (pinLine pin) lineValue
setAllPins :: Ptr G.LineRequest -> G.LineValue -> IO ()
setAllPins lineRequest lineValue = do
logMsg
$ "Setting all pins "
<> pack (show allPins)
<> " to state "
<> pack (show lineValue)
void
$ V.unsafeWith (V.replicate (length allPins) lineValue)
$ G.lineRequestSetValues lineRequest
allocateGPIO :: Region -> Text -> IO (Ptr G.LineRequest)
allocateGPIO region consumer = do
(chip, chipKey) <- allocateChip
(lineSettings, lineSettingsKey) <- allocateLineSettings
(lineConfig, lineConfigKey) <- allocateLineConfig lineSettings
(requestConfig, requestConfigKey) <- allocateRequestConfig
lineRequest <- allocateLineRequest chip requestConfig lineConfig
free requestConfigKey
free lineConfigKey
free lineSettingsKey
free chipKey
defer region $ setAllPins lineRequest G.inactive
return lineRequest
where
chipPath = "/dev/gpiochip0"
-- GPIO chip
chipOpen = do
logMsg $ "Opening GPIO chip " <> chipPath
useAsCString (encodeUtf8 chipPath) G.chipOpen
chipClose chip = do
logMsg $ "Closing GPIO chip " <> chipPath
G.chipClose chip
allocateChip = alloc region chipOpen chipClose
-- Line settings
lineSettingsNew = do
logMsg "Allocating line settings"
lineSettings <- G.lineSettingsNew
logMsg $ "With direction set to " <> pack (show G.output)
void $ G.lineSettingsSetDirection lineSettings G.output
logMsg $ "With output set to " <> pack (show G.inactive)
void $ G.lineSettingsSetOutputValue lineSettings G.inactive
return lineSettings
lineSettingsFree lineSettings = do
logMsg "Freeing line settings"
G.lineSettingsFree lineSettings
allocateLineSettings = alloc region lineSettingsNew lineSettingsFree
-- Line config
lineConfigNew lineSettings = do
logMsg "Allocating line config"
logMsg $ "With GPIO pins " <> pack (show allPins)
lineConfig <- G.lineConfigNew
void
$ V.unsafeWith (V.fromList allLines)
$ \pinsVector ->
G.lineConfigAddLineSettings
lineConfig
pinsVector
(CSize $ fromIntegral $ length allPins)
lineSettings
return lineConfig
lineConfigFree lineConfig = do
logMsg "Freeing line config"
G.lineConfigFree lineConfig
allocateLineConfig lineSettings =
alloc region (lineConfigNew lineSettings) lineConfigFree
-- Request config
requestConfigNew = do
logMsg "Allocating request config"
logMsg $ "With consumer " <> consumer
requestConfig <- G.requestConfigNew
useAsCString (encodeUtf8 consumer)
$ G.requestConfigSetConsumer requestConfig
return requestConfig
requestConfigFree requestConfig = do
logMsg "Freeing request config"
G.requestConfigFree requestConfig
allocateRequestConfig = alloc region requestConfigNew requestConfigFree
-- Line request
requestLines chip requestConfig lineConfig = do
logMsg "Allocating line request"
G.requestLines chip requestConfig lineConfig
lineRequestRelease lineRequest = do
logMsg "Releasing line request"
G.lineRequestRelease lineRequest
allocateLineRequest chip requestConfig lineConfig =
alloc_
region
(requestLines chip requestConfig lineConfig)
lineRequestRelease
|
