aboutsummaryrefslogtreecommitdiff
path: root/hsm-pwm/Hsm/PWM.hs
diff options
context:
space:
mode:
Diffstat (limited to 'hsm-pwm/Hsm/PWM.hs')
-rw-r--r--hsm-pwm/Hsm/PWM.hs210
1 files changed, 104 insertions, 106 deletions
diff --git a/hsm-pwm/Hsm/PWM.hs b/hsm-pwm/Hsm/PWM.hs
index 6b2a882..aa16d5c 100644
--- a/hsm-pwm/Hsm/PWM.hs
+++ b/hsm-pwm/Hsm/PWM.hs
@@ -1,143 +1,141 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# 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
- ( PWMHandle
- , PWMChannel(PWM2, PWM3)
+ ( PWMChannel (..)
+ , PWM
, setCycleDuration
- , allocatePWM
- ) where
+ , runPWM
+ )
+where
import Control.Concurrent (threadDelay)
-import Control.IO.Region (Region, alloc_)
+import Control.Monad (forM_, void)
import Control.Monad.Loops (untilM_)
-import Data.Text (Text, pack)
-import Hsm.Log qualified as L
+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)
--- 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
+$(makeSerial "PWM" "Channel" "channelIndex" ''Int [1, 2])
--- 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 PWM (a :: * -> *) (b :: *)
+
+type instance DispatchOf PWM = Static WithSideEffects
-logMsg :: Text -> IO ()
-logMsg = L.logMsg ["pwm"]
+newtype instance StaticRep PWM
+ = PWM ()
chipPath :: FilePath
chipPath = "/sys/class/pwm/pwmchip0"
-channelIndex :: PWMChannel -> Int
-channelIndex = read . drop 3 . show
+channelPath :: PWMChannel -> FilePath
+channelPath channel = chipPath </> "pwm" <> show (channelIndex channel)
-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"
+enablePath :: PWMChannel -> FilePath
+enablePath channel = channelPath channel </> "enable"
-setEnable :: PWMChannel -> Bool -> IO ()
+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 $ "Setting " <> pack enablePath <> " to " <> pack (show enable)
- writeFile enablePath enableString
- where
- (enablePath, _, _) = channelPaths channel
- enableString = show $ fromEnum enable
+ logMsg Trace $ "Setting " <> enablePath channel <> " to " <> show enable
+ unsafeEff_ . writeFile (enablePath channel) . show $ fromEnum enable
-setPeriod :: PWMChannel -> Int -> IO ()
+setPeriod :: (Log "pwm" :> es, PWM :> es) => PWMChannel -> Int -> Eff es ()
setPeriod channel period = do
- logMsg $ "Setting " <> pack periodPath <> " to " <> pack (show period)
- writeFile periodPath $ show period
- where
- (_, periodPath, _) = channelPaths channel
+ logMsg Trace $ "Setting " <> periodPath channel <> " to " <> show period
+ unsafeEff_ . writeFile (periodPath channel) $ show period
-setDutyCycle :: PWMChannel -> Int -> IO ()
+setDutyCycle :: (Log "pwm" :> es, PWM :> es) => PWMChannel -> Int -> Eff es ()
setDutyCycle channel dutyCycle = do
- logMsg $ "Setting " <> pack dutyCyclePath <> " to " <> pack (show dutyCycle)
- writeFile dutyCyclePath $ show dutyCycle
- where
- (_, _, dutyCyclePath) = channelPaths channel
+ logMsg Trace $ "Setting " <> dutyCyclePath channel <> " to " <> show dutyCycle
+ unsafeEff_ . writeFile (dutyCyclePath channel) $ show dutyCycle
-setCycleDuration :: PWMHandle -> PWMChannel -> Int -> IO ()
-setCycleDuration _ channel 0 = do
- logMsg $ "Halting PWM signals on channel " <> pack (show channel)
+-- 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
- $ "Setting cycle duration on channel "
- <> pack (show channel)
- <> " to "
- <> pack (show cycleDuration)
+setCycleDuration channel cycleDuration = do
+ logMsg Trace $
+ "Setting cycle duration on channel "
+ <> show channel
+ <> " to "
+ <> show cycleDuration
setEnable channel False
- -- Sets the duty cycle to zero before updating the period. This prevents
- -- `Invalid argument` errors, as the period must never be set to a value
- -- smaller than the duty cycle.
setDutyCycle channel 0
setPeriod channel cycleDuration
setDutyCycle channel $ cycleDuration `div` 2
setEnable channel True
-allocatePWM :: Region -> (PWMChannel -> Int) -> IO PWMHandle
-allocatePWM region mapper = alloc_ region acquire $ const release
+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"
- -- 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.
+ -- 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 $ "Waiting for " <> pack path <> " to become writable"
- untilM_ (threadDelay 1000) $ fileAccess path False True False
+ logMsg Info $ "Waiting for " <> path <> " to become writable"
+ liftIO . 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
- setCycleDuration PWMHandle channel $ mapper channel
- acquire = do
+ pwmAlloc = do
waitWritable exportPath
waitWritable unexportPath
- mapM_ acquireChannel allChannels
- return PWMHandle
- -- Release PWM channels
- releaseChannel channel = do
- setEnable channel False
- logMsg
- $ "Unexporting channel "
- <> pack (show channel)
- <> " on chip "
- <> pack chipPath
- writeFile unexportPath $ show (channelIndex channel)
- release = mapM_ releaseChannel allChannels
+ 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)
powered by cgit v1.2.1, back to main portfolio site