Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
169 lines (145 sloc) 5.61 KB
{-|
This program demonstrates how to use the 'SysfsGpioT' transformer with
a transformer stack.
-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
-- Protolude uses <> and options from Semigroups, but
-- optparse-applicative hasn't caught up yet.
import Protolude hiding ((<>))
import Control.Monad.Catch (MonadMask)
import Data.Monoid ((<>))
import Data.Text (unwords)
import Options.Applicative
(Parser, argument, auto, command, execParser, fullDesc, header,
help, helper, hsubparser, info, long, metavar, progDesc, short,
showDefault, value)
import qualified Options.Applicative as Options (option)
import System.GPIO.Linux.Sysfs (SysfsIOT, SysfsGpioT, runSysfsGpioT, runSysfsIOT, runSysfsGpioIO)
import System.GPIO.Monad
(MonadGpio, Pin, PinInputMode(..), PinInterruptMode(..),
PinOutputMode(..), PinValue(..), pins, pollPinTimeout,
setPinInputMode, setPinInterruptMode, setPinOutputMode, togglePin,
withPin)
-- Only one for now.
data Interpreter =
SysfsIO
deriving (Eq,Show,Read)
data GlobalOptions =
GlobalOptions {_interpreter :: !Interpreter
,_cmd :: !Command}
data Command
= ListPins
| PollPin PollPinOptions
listPinsCmd :: Parser Command
listPinsCmd = pure ListPins
data PollPinOptions =
PollPinOptions {_period :: !Int
,_interruptMode :: !PinInterruptMode
,_timeout :: !Int
,_outputPin :: !Pin
,_inputPin :: !Pin}
pollPinCmd :: Parser Command
pollPinCmd = PollPin <$> pollPinOptions
oneSecond :: Int
oneSecond = 1 * 1000000
pollPinOptions :: Parser PollPinOptions
pollPinOptions =
PollPinOptions <$>
Options.option auto (long "period" <>
short 'p' <>
metavar "INT" <>
value oneSecond <>
showDefault <>
help "Delay between output pin value toggles (in microseconds)") <*>
Options.option auto (long "trigger" <>
short 't' <>
metavar "Disabled|RisingEdge|FallingEdge|Level" <>
value Level <>
showDefault <>
help "Event on which to trigger the input pin") <*>
Options.option auto (long "timeout" <>
short 'T' <>
metavar "INT" <>
value (-1) <>
help "Poll timeout (in microseconds)") <*>
argument auto (metavar "INPIN") <*>
argument auto (metavar "OUTPIN")
cmds :: Parser GlobalOptions
cmds =
GlobalOptions <$>
Options.option auto (long "interpreter" <>
short 'i' <>
metavar "SysfsIO" <>
value SysfsIO <>
showDefault <>
help "Choose the GPIO interpreter (system) to use") <*>
hsubparser
(command "listPins" (info listPinsCmd (progDesc "List the GPIO pins available on the system")) <>
command "pollPin" (info pollPinCmd (progDesc "Drive INPIN using OUTPIN. (Make sure the pins are connected!")))
data Config =
Config {_pin :: Pin
,_trigger :: PinInterruptMode
,_wait :: Int}
deriving ((Show))
-- | Our 'IO' transformer stack:
-- * A reader monad.
-- * The Linux @sysfs@ GPIO interpreter
-- * The (real) Linux @sysfs@ back-end.
-- * 'IO'
type SysfsGpioReaderIO a = ReaderT Config (SysfsGpioT (SysfsIOT IO)) a
-- | The interpreter for our IO transformer stack.
runSysfsGpioReaderIO :: SysfsGpioReaderIO a -> Config -> IO a
runSysfsGpioReaderIO act config = runSysfsIOT $ runSysfsGpioT $ runReaderT act config
run :: GlobalOptions -> IO ()
run (GlobalOptions SysfsIO (PollPin (PollPinOptions period mode timeout inputPin outputPin))) =
void $
concurrently
(runSysfsGpioReaderIO pollInput (Config inputPin mode timeout))
(runSysfsGpioReaderIO driveOutput (Config outputPin Disabled period))
-- The 'listPins' program takes no arguments, so we don't need our
-- custom 'IO' transformer stack here.
run (GlobalOptions SysfsIO ListPins) = runSysfsGpioIO listPins
-- | Define some constraint types that work with multiple 'MonadGpio'
-- interpreters.
type GpioM h m = (Applicative m, MonadMask m, MonadIO m, MonadGpio h m)
type GpioReaderM h m = (Applicative m, MonadMask m, MonadIO m, MonadGpio h m, MonadReader Config m)
listPins :: (GpioM h m) => m ()
listPins =
pins >>= \case
[] -> putText "No GPIO pins found on this system"
ps -> for_ ps $ putText . show
pollInput :: (GpioReaderM h m) => m ()
pollInput =
do p <- asks _pin
mode <- asks _trigger
timeout <- asks _wait
withPin p $ \h ->
do setPinInputMode h InputDefault
setPinInterruptMode h mode
forever $
do result <- pollPinTimeout h timeout
case result of
Nothing -> putText $ unwords ["readPin timed out after", show timeout, "microseconds"]
Just v -> putText $ unwords ["Input:", show v]
driveOutput :: (GpioReaderM h m) => m ()
driveOutput =
do p <- asks _pin
delay <- asks _wait
withPin p $ \h ->
do setPinOutputMode h OutputDefault Low
forever $
do liftIO $ threadDelay delay
v <- togglePin h
putText $ unwords ["Output:", show v]
main :: IO ()
main = execParser opts >>= run
where
opts =
info (helper <*> cmds)
(fullDesc <>
progDesc "Example hpio programs." <>
header "hpio-reader-example - run hpio demonstrations.")
You can’t perform that action at this time.