fuyu-gpio-0.1.0.0: examples/04-led-and-button.hs

-- In this example we will learn how to coordinate GPIO output (LED blinking) and input (button press)
-- concurrently using 'forkIO' and an 'MVar' to dynamically control the LED blinking speed upon
-- detecting button press edge events.
--
-- We introduce 'Control.Monad.Managed' ('managed', 'runManaged') to acquire and compose nested resources
-- in a clean, linear 'do' block. This effectively eliminates the "Pyramid of Doom" (deeply nested 'with*'
-- brackets) in an accessible, lightweight manner before introducing more advanced abstractions like
-- monad transformers ('ContT' / 'StateT') in example 05.
module Main where

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

-- Base & third-party libraries.
import Control.Monad.Managed (managed, runManaged, liftIO)
-- For concurrent medium size programs, 'Control.Concurrent' is awesome.  
import Control.Concurrent (MVar, forkIO, killThread, modifyMVar_, newMVar, readMVar, threadDelay)
-- Besides the functions and types we used before (to manage Ctrl+c exit), we alse need 'finally' to ensure
-- the cleanup of the concurrent thread when the main loop ends or is interrupted.
import Control.Exception (finally, catch, throwIO, AsyncException(UserInterrupt))
import Control.Monad (forever)
import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout)

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

-- This constant defines the maximum duration 'waitEvents' will wait for an event.
-- A short 100ms timeout yields execution back to the RTS so worker threads run smoothly.
waitTimeoutNs :: Edge.Timeout
waitTimeoutNs = Edge.Nanoseconds 100000000 

-- Do not confuse this with kernel ring buffer capacity. 'Capacity' refers to the user-space event buffer.
-- It is clamped between 1 and 1024, and must be constructed via 'userBufferCapacity'
-- (passing 0 defaults to 64).
bufferCapacity :: Edge.Capacity
bufferCapacity = Edge.userBufferCapacity 1

ledOffset :: Offset
ledOffset = Offset 256 

buttonOffset :: Offset
buttonOffset = Offset 271

type Microseconds = Int

-- Available blinking speed states.
data LooptimeState = OneSec | HalfSec | FifthOfSec | TenthOfSec
  deriving (Eq, Show)

-- Convert LooptimeState into delay duration in microseconds.
stateToMicroseconds :: LooptimeState -> Microseconds
stateToMicroseconds OneSec     = 1000000 -- 1.0s delay
stateToMicroseconds HalfSec    = 500000  -- 0.5s delay
stateToMicroseconds FifthOfSec = 200000  -- 0.2s delay
stateToMicroseconds TenthOfSec = 100000  -- 0.1s delay

-- Cycle to the next blinking speed state.
nextSpeed :: LooptimeState -> LooptimeState 
nextSpeed OneSec     = HalfSec
nextSpeed HalfSec    = FifthOfSec
nextSpeed FifthOfSec = TenthOfSec
nextSpeed TenthOfSec = OneSec

myLedSettings :: Settings -> IO ()
myLedSettings stgs = setDirection stgs DirOutput

myButtonSettings :: Settings -> IO ()
myButtonSettings stgs = do
  setDirection stgs DirInput        -- Configure line as input mode.
  setBias stgs BiasPullUp           -- Enable internal pull-up resistor.
                                    -- (the physical button connects GND when pressed, driving the line to Inactive).
  setDebouncePeriodUs stgs 80000    -- 80ms native kernel debounce period to filter out mechanical contact bounce without threadDelay.
  setEdgeDetection stgs EdgeFalling -- Listen for Falling edge transitions (button press to GND).

-- Blinks the LED continuously using the delay duration read from the MVar.
ledWorker :: Request -> MVar LooptimeState -> IO ()
ledWorker req speedMVar = forever $ do
  lts <- readMVar speedMVar
  let delayUs = stateToMicroseconds lts
  setLineValue req ledOffset Active
  threadDelay delayUs
  setLineValue req ledOffset Inactive
  threadDelay delayUs

-- Listens for button edge events and cycles the blinking speed state.
buttonWorker :: Request -> Edge.Buffer -> MVar LooptimeState -> IO ()
buttonWorker req buf speedMVar = do
  res <- Edge.waitEvents req waitTimeoutNs
  case res of
    Edge.EventReady readyReq -> do
      _events <- Edge.readEvents readyReq buf -- Read events from user buffer (configured with capacity 1).
      modifyMVar_ speedMVar (return . nextSpeed)
    Edge.TimeoutResult -> threadDelay 20000 -- 20ms pause to yield file descriptor to LED worker thread.

withAppConfig :: Settings -> Settings -> (Config -> IO r) -> IO r
withAppConfig ledStgs btnStgs action =
   withConfig $ \config -> do   
     addSettings config [ledOffset]  ledStgs
     addSettings config [buttonOffset]  btnStgs
     action config
        
withAppRequest :: Chip -> Config -> (Request -> IO r) -> IO r
withAppRequest chip = withRequest chip Nothing 

main :: IO ()
main = runApp `catch` \exc -> case exc of
  UserInterrupt -> putStrLn "\nLoop terminated seccessfully!"
  other         -> throwIO other 

--  The next lines shows us how to manage libgpiod resources with managed package 
-- (avoiding the Pyramid of Doom).
  
runApp :: IO ()
runApp = do
  hSetBuffering stdout NoBuffering
  initialSpeedMVar <- newMVar OneSec

  -- Instead of nesting 6 levels of 'with*' brackets, 'runManaged' flattens
  -- resource acquisition sequentially while guaranteeing safe cleanup on exit.
  runManaged $ do
    chip        <- managed (withChip myChipPath)
    ledSettings <- managed withSettings
    btnSettings <- managed withSettings
    liftIO $ do
      myLedSettings ledSettings
      myButtonSettings btnSettings
    config      <- managed (withAppConfig ledSettings btnSettings)
    request     <- managed (withAppRequest chip config)
    buffer      <- managed (Edge.withBuffer bufferCapacity)
    liftIO (appLoop request initialSpeedMVar buffer)
  
appLoop :: Request -> MVar LooptimeState -> Edge.Buffer -> IO ()
appLoop request speed buffer = do
  setLineValue request ledOffset Inactive
  putStrLn "Loop started: LED blinking concurrently. Press the button to change speed, or Ctrl+C to exit"
  tid <- forkIO (forever $ ledWorker request speed)
  forever (buttonWorker request buffer speed) `finally` killThread tid

{-
-- For comparison, here is how 'runApp' would look without 'Control.Monad.Managed'
-- (demonstrating the "Pyramid of Doom" caused by multiple nested brackets):

runAppPyramid :: IO ()
runAppPyramid = do
  hSetBuffering stdout NoBuffering
  initialSpeedMVar <- newMVar OneSec
  withChip chipPath $ \chip -> do  
    withSettings $ \btnStgs -> do
      myButtonSettings btnStgs
      withSettings $ \ledStgs -> do 
        myLedSettings ledStgs
        withConfig $ \config -> do
          addSettings config (singleton ledOffset) ledStgs
          addSettings config (singleton buttonOffset) btnStgs
          withRequest chip Nothing config $ \request -> do
            withBuffer bufferCapacity $ \buffer -> do
              appLoop request initialSpeedMVar buffer
-}