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
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Hsm.GPIO
( GPIO(..)
, GPIOEffect
, toggle
, runGPIO
) where
import Data.Aeson (FromJSON)
import Data.Kind (Type)
import Data.List (intercalate)
import Data.Set (Set, toList, unions)
import Data.String (IsString)
import Data.Text (Text, pack)
import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>))
import Effectful.Dispatch.Static qualified as E
import Effectful.Exception (finally)
import Effectful.Log (Log, localDomain, logTrace_)
import GHC.Generics (Generic)
import Hsm.Core.Log (flushLogger)
import System.Process (callCommand)
-- Monofunctional GPIO pins
data GPIO
= GPIO5
| GPIO6
| GPIO16
| GPIO17
| GPIO22
| GPIO23
| GPIO24
| GPIO25
| GPIO26
| GPIO27
deriving (Eq, FromJSON, Generic, Ord, Read, Show)
data GPIOEffect key a b
type instance DispatchOf (GPIOEffect key) = Static E.WithSideEffects
-- Effect state is a mapping function from type `key` to a `Set` of GPIO pins.
-- This enables `key`s of any type to control many pins simultaneously. Using
-- a function (instead of `Data.Map`) ensures all keys map to pins, given the
-- provided function is total.
newtype instance E.StaticRep (GPIOEffect (key :: Type)) =
GPIOEffect (key -> Set GPIO)
domain :: Text
domain = "gpio"
stateStr :: IsString a => Bool -> a
stateStr True = "on"
stateStr False = "off"
-- To control the pins, I use a subprocess call to `gpioset`. In the future
-- I'd prefer wrapping `libgpiod` directly. It looks like no one has created a
-- C wrapper yet, I might do it if I get bored. :)
gpioset :: Log :> es => Bool -> Set GPIO -> [Int] -> Eff es ()
gpioset state gpios periods = do
localDomain domain $ logTrace_ $ "Calling command: " <> pack command
E.unsafeEff_ $ callCommand command
where
command :: String
command =
"gpioset -t"
<> intercalate "," (show <$> periods)
<> " "
<> concatMap lineArg (toList gpios)
--
lineArg :: GPIO -> String
lineArg gpio = show gpio <> "=" <> stateStr state <> " "
getGPIOs :: GPIOEffect key :> es => key -> Eff es (Set GPIO)
getGPIOs key = do
GPIOEffect mapper <- E.getStaticRep
return $ mapper key
logReport ::
(Log :> es, Show key) => Bool -> key -> [Int] -> Set GPIO -> Eff es ()
logReport state key periods gpios = do
localDomain domain $ logTrace_ report
flushLogger
where
report :: Text
report =
"Setting pins "
<> pack (show gpios)
<> " mapped to key "
<> pack (show key)
<> " to state "
<> pack (show state)
<> " using periods "
<> pack (show periods)
toggle ::
(GPIOEffect key :> es, Log :> es, Show key)
=> Bool
-> key
-> [Int]
-> Eff es ()
toggle state key periods = do
gpios <- getGPIOs key
logReport state key periods gpios
gpioset state gpios periods
runGPIO ::
forall key es a. (IOE :> es, Log :> es, Bounded key, Enum key)
=> (key -> Set GPIO)
-> Eff (GPIOEffect key : es) a
-> Eff es a
runGPIO mapper action =
E.evalStaticRep (GPIOEffect mapper) $ finally action releaser
where
gpios :: Set GPIO
gpios = unions $ mapper <$> [minBound .. maxBound]
--
endReport :: Text
endReport =
"Setting all mapped pins "
<> pack (show gpios)
<> " to state "
<> stateStr False
--
releaser :: Eff (GPIOEffect key : es) ()
releaser = do
localDomain domain $ logTrace_ endReport
gpioset False gpios [0]
|
