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
|
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
-- Raspberry Pi 5 PWM control (sysfs interface)
--
-- Requires:
-- - `dtoverlay=pwm-2chan` in `/boot/config.txt`
-- - UDEV rules for non-root access
--
-- Supports 2 active PWM channels. For details see:
-- - PWM Configuration: https://www.pi4j.com/blog/2024/20240423_pwm_rpi5/#modify-configtxt
-- - SysFS Reference: https://forums.raspberrypi.com/viewtopic.php?t=359251
-- - UDEV Setup: https://forums.raspberrypi.com/viewtopic.php?t=316514
module Hsm.PWM
( PWMChannel (..)
, PWM
, setCycleDuration
, runPWM
)
where
import Control.Concurrent (threadDelay)
import Control.Monad (forM_, void)
import Control.Monad.Loops (untilM_)
import Effectful (Dispatch (Static), DispatchOf, Eff, IOE, liftIO, (:>))
import Effectful.Dispatch.Static
( SideEffects (WithSideEffects)
, StaticRep
, evalStaticRep
, unsafeEff_
)
import Effectful.Resource (Resource, allocateEff_)
import Hsm.Core.Serial (makeSerial)
import Hsm.Log (Log, Severity (Info, Trace), logMsg)
import System.FilePath ((</>))
import System.Posix.Files (fileAccess)
$(makeSerial "PWM" "Channel" "channelIndex" ''Int [1, 2])
data PWM (a :: * -> *) (b :: *)
type instance DispatchOf PWM = Static WithSideEffects
newtype instance StaticRep PWM
= PWM ()
chipPath :: FilePath
chipPath = "/sys/class/pwm/pwmchip0"
channelPath :: PWMChannel -> FilePath
channelPath channel = chipPath </> "pwm" <> show (channelIndex channel)
enablePath :: PWMChannel -> FilePath
enablePath channel = channelPath channel </> "enable"
periodPath :: PWMChannel -> FilePath
periodPath channel = channelPath channel </> "period"
dutyCyclePath :: PWMChannel -> FilePath
dutyCyclePath channel = channelPath channel </> "duty_cycle"
setEnable :: (Log "pwm" :> es, PWM :> es) => PWMChannel -> Bool -> Eff es ()
setEnable channel enable = do
logMsg Trace $ "Setting " <> enablePath channel <> " to " <> show enable
unsafeEff_ . writeFile (enablePath channel) . show $ fromEnum enable
setPeriod :: (Log "pwm" :> es, PWM :> es) => PWMChannel -> Int -> Eff es ()
setPeriod channel period = do
logMsg Trace $ "Setting " <> periodPath channel <> " to " <> show period
unsafeEff_ . writeFile (periodPath channel) $ show period
setDutyCycle :: (Log "pwm" :> es, PWM :> es) => PWMChannel -> Int -> Eff es ()
setDutyCycle channel dutyCycle = do
logMsg Trace $ "Setting " <> dutyCyclePath channel <> " to " <> show dutyCycle
unsafeEff_ . writeFile (dutyCyclePath channel) $ show dutyCycle
-- Sets the PWM cycle duration (period) for a channel
--
-- - Special case: A duration of 0 halts PWM output
-- - Normal operation:
-- 1. Zero the duty cycle first to avoid 'Invalid argument' errors
-- (period cannot be smaller than current duty cycle)
-- 2. Update period
-- 3. Set default 50% duty cycle
-- 4. Re-enable output
setCycleDuration
:: (Log "pwm" :> es, PWM :> es) => PWMChannel -> Int -> Eff es ()
setCycleDuration channel 0 = do
logMsg Trace $ "Halting PWM signals on channel " <> show channel
setEnable channel False
setCycleDuration channel cycleDuration = do
logMsg Trace $
"Setting cycle duration on channel "
<> show channel
<> " to "
<> show cycleDuration
setEnable channel False
setDutyCycle channel 0
setPeriod channel cycleDuration
setDutyCycle channel $ cycleDuration `div` 2
setEnable channel True
runPWM
:: (IOE :> es, Log "pwm" :> es, Resource :> es)
=> Eff (PWM : es) a
-> Eff es a
runPWM action =
evalStaticRep (PWM ()) $ do
void $ allocateEff_ pwmAlloc pwmDealloc
action
where
exportPath = chipPath </> "export"
unexportPath = chipPath </> "unexport"
-- Blocks until the PWM sysfs file becomes writable
--
-- Handles the race condition caused by:
-- 1. Sysfs file creation
-- 2. UDEV rules (async `chown` to `pwm` group)
--
-- Polls permissions with 1ms delay between checks.
waitWritable path = do
logMsg Info $ "Waiting for " <> path <> " to become writable"
liftIO . untilM_ (threadDelay 1000) $ fileAccess path False True False
allChannels = [minBound .. maxBound]
pwmAlloc = do
waitWritable exportPath
waitWritable unexportPath
forM_ allChannels $ \channel -> do
logMsg Info $
"Exporting channel " <> show channel <> " on chip " <> chipPath
liftIO . writeFile exportPath $ show (channelIndex channel)
waitWritable $ enablePath channel
waitWritable $ periodPath channel
waitWritable $ dutyCyclePath channel
setCycleDuration channel 0
pwmDealloc =
forM_ allChannels $ \channel -> do
setEnable channel False
logMsg Info $
"Unexporting channel " <> show channel <> " on chip " <> chipPath
liftIO . writeFile unexportPath $ show (channelIndex channel)
|
