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
|
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Hsm.PWM
( PWMEffect
, dutyCycle
, withPWM
, runPWM
) where
import Control.Monad.Loops (untilM_)
import Data.Text (Text, pack)
import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>))
import Effectful.Concurrent (Concurrent, threadDelay)
import Effectful.Dispatch.Static qualified as E
import Effectful.Exception (bracket_)
import Effectful.Log (Log, localDomain, logTrace_)
import Effectful.Reader.Static (Reader, ask)
import GHC.Records (HasField)
import System.FilePath ((</>))
import System.Posix.Files (fileAccess)
-- This `PWMEffect` implementation assumes `dtoverlay=pwm` is set in
-- `/boot/config.txt`, enabling PWM on GPIO 18 (channel 2) for the Pi 5. The
-- address attribute will be 2. Alternative configurations with additional PWM
-- channels are possible. For more information, consult the following links:
--
-- - Modifications to `config.txt`:
-- https://www.pi4j.com/blog/2024/20240423_pwm_rpi5/#modify-configtxt
--
-- - SysFS PWM interface:
-- https://forums.raspberrypi.com/viewtopic.php?t=359251
--
-- - UDEV setup for non-root access:
-- https://forums.raspberrypi.com/viewtopic.php?t=316514
data PWMEffect a b
type instance DispatchOf PWMEffect = Static E.WithSideEffects
newtype instance E.StaticRep PWMEffect =
PWMEffect ()
domain :: Text
domain = "pwm"
pwmchip :: FilePath
pwmchip = "/sys/class/pwm/pwmchip0"
exportPath :: FilePath
exportPath = pwmchip </> "export"
unexportPath :: FilePath
unexportPath = pwmchip </> "unexport"
chanIdx :: Word
chanIdx = 2
chanPath :: FilePath
chanPath = pwmchip </> ("pwm" <> show chanIdx)
enablePath :: FilePath
enablePath = chanPath </> "enable"
periodPath :: FilePath
periodPath = chanPath </> "period"
dutyCyclePath :: FilePath
dutyCyclePath = chanPath </> "duty_cycle"
-- This function waits for a file at the given `path` to become writable by
-- the `pwm` user group. A UDEV rule ensures that files in
-- `/sys/class/pwm/pwmchip*` are made writable through a `chown` call.
-- However, because UDEV rules are applied asynchronously, there may be a
-- brief delay before the rule takes effect. This function blocks and
-- repeatedly checks the file's write permissions by calling `fileAccess`. It
-- continues checking until write access is confirmed.
waitWritable :: (Concurrent :> es, Log :> es) => FilePath -> Eff es ()
waitWritable path = do
logTrace_ $ "Waiting for " <> pack path <> " to become writable"
untilM_ (threadDelay 1000) $ E.unsafeEff_ (fileAccess path False True False)
dutyCycle :: (Concurrent :> es, Log :> es, PWMEffect :> es) => Word -> Eff es ()
dutyCycle dc = do
localDomain domain $ logTrace_ $ "Setting duty cycle to " <> pack (show dc)
E.unsafeEff_ $ writeFile (chanPath </> "duty_cycle") $ show dc
disable :: (Concurrent :> es, Log :> es, PWMEffect :> es) => Eff es ()
disable = do
dutyCycle 0
localDomain domain
$ logTrace_
$ "Disabling PWM channel " <> pack (show chanIdx)
E.unsafeEff_ $ writeFile enablePath "0"
withPWM ::
(Concurrent :> es, Log :> es, PWMEffect :> es) => Eff es a -> Eff es a
withPWM = bracket_ activate disable
where
activate = do
localDomain domain
$ logTrace_
$ "Enabling PWM channel " <> pack (show chanIdx)
E.unsafeEff_ $ writeFile enablePath "1"
runPWM ::
forall env es a.
( HasField "pwmPeriod" env Word
, Concurrent :> es
, IOE :> es
, Log :> es
, Reader env :> es
)
=> Eff (PWMEffect : es) a
-> Eff es a
runPWM = E.evalStaticRep (PWMEffect ()) . bracket_ acquire release
where
acquire = do
localDomain domain $ do
waitWritable exportPath
waitWritable unexportPath
logTrace_
$ "Exporting channel "
<> pack (show chanIdx)
<> " on chip "
<> pack pwmchip
E.unsafeEff_ $ writeFile exportPath $ show chanIdx
waitWritable enablePath
waitWritable periodPath
waitWritable dutyCyclePath
env <- ask @env
logTrace_ $ "Fixing period to " <> pack (show env.pwmPeriod)
E.unsafeEff_ $ writeFile periodPath $ show env.pwmPeriod
disable
release = do
disable
localDomain domain
$ logTrace_
$ "Unexporting channel "
<> pack (show chanIdx)
<> " on chip "
<> pack pwmchip
E.unsafeEff_ $ writeFile unexportPath $ show chanIdx
|
