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
|
{-# 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
lineArg gpio = show gpio <> "=" <> stateStr state <> " "
command =
"gpioset -t"
<> intercalate "," (show <$> periods)
<> " "
<> concatMap lineArg (toList gpios)
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 =
"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
GPIOEffect mapper <- E.getStaticRep
set $ mapper key
where
set gpios = do
logReport state key periods gpios
gpioset state gpios periods
runGPIO ::
(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 release
where
gpios = unions $ mapper <$> [minBound .. maxBound]
endReport =
"Setting all mapped pins "
<> pack (show gpios)
<> " to state "
<> stateStr False
release = do
localDomain domain $ logTrace_ endReport
gpioset False gpios [0]
|
