fuyu-gpio-0.1.0.0: examples/05-request-config.hs

{-# LANGUAGE OverloadedStrings #-}
-- In this example we will learn how to read a rotary encoder using a custom 'RequestConfig',
-- flattening resource allocation brackets with monadic continuation ('ContT'), and managing state
-- cleanly with 'Control.Monad.Trans.State.Strict' (StateT).
module Main where

-- High-level resource brackets & exception handling
import Fuyu.GPIO 
import qualified Fuyu.GPIO.EdgeEvent as Edge 
import qualified Fuyu.GPIO.RequestConfig as ReqConf  

-- Base & core libraries ('transformers' is a core GHC boot package with zero external dependencies).
import Control.Monad.Trans.Cont (evalContT, ContT(..))
-- We import 'Control.Monad.Trans.State.Strict' directly from 'transformers' rather than
-- 'Control.Monad.State' from 'mtl' to keep external dependencies minimal.
-- We explicitly choose the strict variant ('.Strict') and use 'modify'' to force evaluation of state
-- updates eagerly. This prevents space leaks (accumulation of unevaluated thunks in memory)
-- as encoder tick counts change continuously.
import Control.Monad.Trans.State.Strict (StateT, evalStateT, gets, modify')
import Control.Monad.IO.Class (liftIO)
import Control.Monad (forever, when)
-- To have a clean exit when Ctrl+C is pressed.
import Control.Exception (catch, throwIO, AsyncException(UserInterrupt))
import Data.List.NonEmpty (NonEmpty(..))

myChipPath :: FilePath
myChipPath = "/dev/gpiochip0"

-- Line offsets for the rotary encoder signals
offsetCLK :: Offset
offsetCLK = Offset 256

offsetDT :: Offset
offsetDT = Offset 271

-- Timeout for waiting on edge events (5 seconds)
fiveSecondsNs :: Edge.Timeout
fiveSecondsNs = Edge.Nanoseconds 5000000000

-- Setting user buffer capacity to 1 guarantees that 'readEvents' returns exactly 1 event at a time.
-- This simplifies pattern matching to '(ev :| _)' without losing any events in the kernel queue.
capacity :: Edge.Capacity
capacity = Edge.userBufferCapacity 1

-- Clean pure Haskell record representing the quadrature state and step count.
data EncoderState = EncoderState
  { clkPin   :: !Int  -- Logical level of CLK line (1 = HIGH, 0 = LOW)
  , dtPin    :: !Int  -- Logical level of DT line (1 = HIGH, 0 = LOW)
  , position :: !Int  -- Accumulated rotary encoder step count
  } deriving (Eq, Show)

-- Initial state at startup (both lines idle at HIGH with 0 position count)
initialState :: EncoderState
initialState = EncoderState { clkPin = 1, dtPin = 1, position = 0 }

main :: IO ()
main = do 
  putStrLn "Starting request config example (Press Ctrl+C to exit)..."
  runApp `catch` \exc -> case exc of
    UserInterrupt -> putStrLn "\nLoop terminated successfully!"
    other         -> throwIO other

-- We need some helpers configurator brackets. 
-- This one encapsulates the creation and configuration of RequestConfig (consumer label & buffer size).
withAppRequestConfig :: (ReqConf.RequestConfig -> IO r) -> IO r
withAppRequestConfig action = ReqConf.withRequestConfig $ \reqconf -> do
  ReqConf.setConsumer reqconf "encoder-app"
  ReqConf.setBufferSize reqconf 256
  action reqconf

-- To encapsulates line settings configuration (input mode, 1ms debounce, edge detection).
withAppLineSettings :: (Settings -> IO r) -> IO r
withAppLineSettings action = withSettings $ \settings -> do
  setDirection settings DirInput
  setDebouncePeriodUs settings 1000 -- 1ms debounce suitable for rotary encoder hardware
  setEdgeDetection settings EdgeBoth 
  action settings

-- And to encapsulates building line configuration for target pin offsets (CLK & DT).
withAppLineConfig :: Settings -> (Config -> IO r) -> IO r
withAppLineConfig settings action = withConfig $ \config -> do
  addSettings config [offsetCLK, offsetDT] settings
  action config

-- Monadic resource setup using 'ContT' (from 'transformers') flattens nested 'with...' brackets
-- into a linear 'do' block. This achieves the same goal as 'runManaged' in example 04, but using
-- standard core transformers without external dependencies.
-- 'evalStateT' then runs the stateful application loop initialized with 'initialState'.
runApp :: IO ()
runApp = evalContT $ do
  chip     <- ContT $ withChip myChipPath
  reqconf  <- ContT withAppRequestConfig
  settings <- ContT withAppLineSettings
  config   <- ContT $ withAppLineConfig settings
  request  <- ContT $ withRequest chip (Just reqconf) config
  buffer   <- ContT $ Edge.withBuffer capacity

  -- Run stateful application loop starting with 'initialState'.
  liftIO $ evalStateT (appLoop request buffer) initialState

-- Application loop running in 'StateT EncoderState IO ()'.
-- Unlike example 04 which used an 'MVar' to share mutable state across concurrent threads ('forkIO'),
-- this example is a single-threaded sequential event loop. 'StateT' provides pure, structured state
-- transitions without the synchronization overhead or locking primitives of MVars.
appLoop :: Request -> Edge.Buffer -> StateT EncoderState IO ()
appLoop request buffer = forever $ do
  result <- liftIO $ Edge.waitEvents request fiveSecondsNs
  case result of
    Edge.TimeoutResult -> 
      liftIO $ putStrLn "No edge event was read (timeout)."

    Edge.EventReady req -> do
      (ev :| _) <- liftIO $ Edge.readEvents req buffer
      oldPos    <- gets position
      
      -- Update pure state cleanly using strict 'modify'. 
      modify' (updateEncoderState ev)
      
      newPos    <- gets position
      when (newPos /= oldPos)
        $ liftIO $ putStrLn $ "Encoder Position: " ++ show newPos

-- Pure function that updates 'EncoderState' based on incoming 'EdgeEvent'.
-- When CLK transitions to LOW (Falling edge), we inspect the current state of DT:
--   - DT == 1 (HIGH) -> Clockwise rotation (+1)
--   - DT == 0 (LOW)  -> Counter-Clockwise rotation (-1)
updateEncoderState :: Edge.Event -> EncoderState -> EncoderState
updateEncoderState (Edge.EdgeEvent offset evType _) st = case (offset, evType) of
  (Offset 256, Edge.Falling) ->
    let delta  = if dtPin st == 1 then 1 else (-1)
    in st { clkPin = 0, position = position st + delta }

  (Offset 256, Edge.Rising)  -> st { clkPin = 1 }
  (Offset 271, Edge.Falling) -> st { dtPin = 0 }
  (Offset 271, Edge.Rising)  -> st { dtPin = 1 }
  _                          -> st