{-# 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)