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
|
{-# 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_)
import Control.Monad.Loops (untilM_)
import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>), liftIO)
import Effectful.Dispatch.Static (SideEffects(WithSideEffects), StaticRep, evalStaticRep, unsafeEff_)
import Effectful.Exception (bracket_)
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) => Eff (PWM : es) a -> Eff es a
runPWM = evalStaticRep (PWM ()) . bracket_ pwmAlloc pwmDealloc
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)
|
