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
|
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
module Hsm.PWM
( PWMHandle
, PWMChannel(PWM2, PWM3)
, PWMConfig(PWMConfig, period, dutyCycle)
, defaultPWMConfig
, setPeriod
, setDutyCycle
, allocatePWM
) where
import Control.Concurrent (threadDelay)
import Control.IO.Region (Region, alloc_)
import Control.Monad.Loops (untilM_)
import Data.Text (Text, pack)
import Hsm.Log qualified as L
import System.FilePath ((</>))
import System.Posix.Files (fileAccess)
-- This data type defines a placeholder `PWMHandle` to ensure that PWM actions
-- occur only after the `allocatePWM` function has been called. The empty
-- handle acts as a flag to enforce the correct order of operations.
data PWMHandle =
PWMHandle
-- This PWM controller assumes `dtoverlay=pwm-2chan` is set in
-- `/boot/config.txt`, enabling PWM on GPIO 18 (channel 2) and GPIO 19
-- (channel 3) for the Pi 5. 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 PWMChannel
= PWM2
| PWM3
deriving (Bounded, Enum, Show)
data PWMConfig = PWMConfig
{ period :: Int
, dutyCycle :: Int
}
defaultPWMConfig :: PWMConfig
defaultPWMConfig = PWMConfig {period = 1000000, dutyCycle = 0}
logMsg :: Text -> IO ()
logMsg = L.logMsg ["pwm"]
chipPath :: FilePath
chipPath = "/sys/class/pwm/pwmchip0"
channelIndex :: PWMChannel -> Int
channelIndex = read . drop 3 . show
channelPaths :: PWMChannel -> (FilePath, FilePath, FilePath)
channelPaths channel = (enablePath, periodPath, dutyCyclePath)
where
channelPath = chipPath </> ("pwm" <> show (channelIndex channel))
enablePath = channelPath </> "enable"
periodPath = channelPath </> "period"
dutyCyclePath = channelPath </> "duty_cycle"
setPeriod :: PWMHandle -> PWMChannel -> Int -> IO ()
setPeriod _ channel period = do
logMsg
$ "Setting period on channel "
<> pack (show channel)
<> " to "
<> pack (show period)
writeFile periodPath $ show period
where
(_, periodPath, _) = channelPaths channel
setDutyCycle :: PWMHandle -> PWMChannel -> Int -> IO ()
setDutyCycle _ channel dutyCycle = do
logMsg
$ "Setting duty cycle on channel "
<> pack (show channel)
<> " to "
<> pack (show dutyCycle)
writeFile dutyCyclePath $ show dutyCycle
where
(_, _, dutyCyclePath) = channelPaths channel
allocatePWM :: Region -> IO PWMHandle
allocatePWM region = alloc_ region acquire $ const release
where
exportPath = chipPath </> "export"
unexportPath = chipPath </> "unexport"
-- 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 path = do
logMsg $ "Waiting for " <> pack path <> " to become writable"
untilM_ (threadDelay 1000) $ fileAccess path False True False
allChannels = [minBound .. maxBound]
-- Acquire PWM channels
acquireChannel channel = do
logMsg
$ "Exporting channel "
<> pack (show channel)
<> " on chip "
<> pack chipPath
writeFile exportPath $ show (channelIndex channel)
let (enablePath, periodPath, dutyCyclePath) = channelPaths channel
waitWritable enablePath
waitWritable periodPath
waitWritable dutyCyclePath
logMsg $ "Enabling channel " <> pack (show channel)
writeFile enablePath "1"
-- Sets default PWM period to 1 us
setPeriod PWMHandle channel 1000
setDutyCycle PWMHandle channel 0
acquire = do
waitWritable exportPath
waitWritable unexportPath
mapM_ acquireChannel allChannels
return PWMHandle
-- Release PWM channels
releaseChannel channel = do
let (enablePath, _, dutyCyclePath) = channelPaths channel
logMsg $ "Setting duty cycle to 0 on channel " <> pack (show channel)
writeFile dutyCyclePath "0"
logMsg $ "Disabling channel " <> pack (show channel)
writeFile enablePath "0"
logMsg
$ "Unexporting channel "
<> pack (show channel)
<> " on chip "
<> pack chipPath
writeFile unexportPath $ show (channelIndex channel)
release = mapM_ releaseChannel allChannels
|
