aboutsummaryrefslogtreecommitdiff
path: root/hsm-pwm/Hsm/PWM.hs
blob: c7bb1e52442f52f8529c6b1defd1e143b2179ae9 (plain)
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
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

module Hsm.PWM
  ( PWMEffect
  , dutyCycle
  , withPWM
  , runPWM
  ) where

import Data.Text (Text, pack)
import Effectful (Dispatch(Static), DispatchOf, Eff, IOE, (:>))
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.Process (callCommand)

-- 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"

chanIdx :: Word
chanIdx = 2

chanPath :: FilePath
chanPath = pwmchip </> ("pwm" <> show chanIdx)

enablePath :: FilePath
enablePath = chanPath </> "enable"

dutyCycle :: (Log :> es, PWMEffect :> es) => Word -> Eff es ()
dutyCycle dc = do
  localDomain domain $ logTrace_ $ "Setting duty cycle to " <> pack (show dc)
  E.unsafeEff_ $ writeFile dutyCyclePath $ show dc
  where
    dutyCyclePath = chanPath </> "duty_cycle"

disable :: (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 :: (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
     , IOE :> es
     , Log :> es
     , Reader env :> es
     )
  => Eff (PWMEffect : es) a
  -> Eff es a
runPWM action = E.evalStaticRep (PWMEffect ()) $ bracket_ acquire release action
  where
    export = pwmchip </> "export"
    period = chanPath </> "period"
    unexport = pwmchip </> "unexport"
    acquire = do
      localDomain domain $ do
        logTrace_
          $ "Exporting channel "
              <> pack (show chanIdx)
              <> " on chip "
              <> pack pwmchip
        E.unsafeEff_ $ writeFile export $ show chanIdx
        logTrace_ "Giving UDEV a chance to settle"
        E.unsafeEff_ $ callCommand "udevadm settle"
        env <- ask @env
        logTrace_ $ "Fixing period to " <> pack (show env.pwmPeriod)
        E.unsafeEff_ $ writeFile period $ show env.pwmPeriod
      disable
    release = do
      disable
      localDomain domain
        $ logTrace_
        $ "Unexporting channel "
            <> pack (show chanIdx)
            <> " on chip "
            <> pack pwmchip
      E.unsafeEff_ $ writeFile unexport $ show chanIdx