hpio (empty) → 0.8.0.0
raw patch · 29 files changed
+6080/−0 lines, 29 filesdep +QuickCheckdep +asyncdep +basesetup-changed
Dependencies added: QuickCheck, async, base, base-compat, bytestring, containers, directory, doctest, exceptions, filepath, hlint, hpio, hspec, mtl, mtl-compat, optparse-applicative, text, transformers, transformers-compat, unix, unix-bytestring
Files
- .travis.yml +138/−0
- Hlint.hs +4/−0
- LICENSE +30/−0
- README.md +14/−0
- Setup.hs +2/−0
- default.nix +29/−0
- examples/Gpio.hs +125/−0
- examples/GpioReader.hs +158/−0
- examples/Sysfs.hs +131/−0
- hpio.cabal +253/−0
- shell.nix +45/−0
- src/System/GPIO.hs +24/−0
- src/System/GPIO/Linux.hs +27/−0
- src/System/GPIO/Linux/Sysfs.hs +115/−0
- src/System/GPIO/Linux/Sysfs/IO.hs +104/−0
- src/System/GPIO/Linux/Sysfs/Mock.hs +708/−0
- src/System/GPIO/Linux/Sysfs/Mock/Internal.hs +238/−0
- src/System/GPIO/Linux/Sysfs/Monad.hs +787/−0
- src/System/GPIO/Linux/Sysfs/Types.hs +158/−0
- src/System/GPIO/Linux/Sysfs/Util.hs +343/−0
- src/System/GPIO/Linux/Sysfs/pollSysfs.c +82/−0
- src/System/GPIO/Monad.hs +833/−0
- src/System/GPIO/Tutorial.hs +1369/−0
- src/System/GPIO/Types.hs +302/−0
- stack-lts-2.yaml +10/−0
- stack.yaml +8/−0
- test/Main.hs +7/−0
- test/doctest.hs +24/−0
- test/hlint.hs +12/−0
+ .travis.yml view
@@ -0,0 +1,138 @@+# Copy these contents into the root directory of your Github project in a file+# named .travis.yml++# Use new container infrastructure to enable caching+sudo: false++# Choose a lightweight base image; we provide our own build tools.+language: c++# Caching so the next build will be fast too.+cache:+ directories:+ - $HOME/.ghc+ - $HOME/.cabal+ - $HOME/.stack++# The different configurations we want to test. We have BUILD=cabal which uses+# cabal-install, and BUILD=stack which uses Stack. More documentation on each+# of those below.+#+# We set the compiler values here to tell Travis to use a different+# cache file per set of arguments.+#+# If you need to have different apt packages for each combination in the+# matrix, you can use a line such as:+# addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}}+matrix:+ include:+ # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See:+ # https://github.com/hvr/multi-ghc-travis+ - env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7+ compiler: ": #GHC 7.8.4"+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}+ - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7+ compiler: ": #GHC 7.10.3"+ addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}+ - env: BUILD=cabal GHCVER=8.0.1 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7+ compiler: ": #GHC 8.0.1"+ addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}++ # Build with the newest GHC and cabal-install. This is an accepted failure,+ # see below.+ - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7+ compiler: ": #GHC HEAD"+ addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}}++ # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS+ # variable, such as using --stack-yaml to point to a different file.+ - env: BUILD=stack ARGS="--resolver lts-2" STACK_YAML=stack-lts-2.yaml+ compiler: ": #stack 7.8.4"+ addons: {apt: {packages: [ghc-7.8.4], sources: [hvr-ghc]}}++ - env: BUILD=stack ARGS="--resolver lts-3" STACK_YAML=stack-lts-2.yaml+ compiler: ": #stack 7.10.2"+ addons: {apt: {packages: [ghc-7.10.2], sources: [hvr-ghc]}}++ - env: BUILD=stack ARGS="--resolver lts-5"+ compiler: ": #stack 7.10.3"+ addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}}++ - env: BUILD=stack ARGS="--resolver lts-6"+ compiler: ": #stack 7.10.3"+ addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}}++ # Nightly builds are allowed to fail+ - env: BUILD=stack ARGS="--resolver nightly"+ compiler: ": #stack nightly"+ addons: {apt: {packages: [libgmp-dev]}}++ # Build on OS X in addition to Linux.+ # OS X builds are much slower, so we only test a few configurations here.+ - env: BUILD=stack ARGS="--resolver lts-2" STACK_YAML=stack-lts-2.yaml+ compiler: ": #stack 7.8.4 osx"+ os: osx++ - env: BUILD=stack ARGS="--resolver lts-6"+ compiler: ": #stack 7.10.3 osx"+ os: osx++ - env: BUILD=stack ARGS="--resolver nightly"+ compiler: ": #stack nightly osx"+ os: osx++ allow_failures:+ - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7+ - env: BUILD=stack ARGS="--resolver nightly"++before_install:+# Using compiler above sets CC to an invalid value, so unset it+- unset CC++# We want to always allow newer versions of packages when building on GHC HEAD+- CABALARGS=""+- if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi++# Download and unpack the stack executable+- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH+- mkdir -p ~/.local/bin+- |+ if [ `uname` = "Darwin" ]+ then+ curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin+ else+ curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'+ fi++install:+- echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"+- if [ -f configure.ac ]; then autoreconf -i; fi+- |+ case "$BUILD" in+ stack)+ stack --no-terminal --install-ghc $ARGS test --only-dependencies+ ;;+ cabal)+ cabal --version+ travis_retry cabal update+ cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS+ ;;+ esac++script:+- |+ case "$BUILD" in+ stack)+ stack --no-terminal $ARGS test --haddock --no-haddock-deps+ ;;+ cabal)+ cabal configure --enable-tests --enable-benchmarks -v2 --ghc-options="-O0 -Werror"+ cabal build+ cabal check || [ "$CABALVER" == "1.16" ]+ cabal test+ cabal sdist+ cabal copy+ SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && \+ (cd dist && cabal install --force-reinstalls "$SRC_TGZ")+ ;;+ esac
+ Hlint.hs view
@@ -0,0 +1,4 @@+import "hint" HLint.HLint++ignore "Use import/export shortcut"+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Drew Hess++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Drew Hess nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,14 @@+# hpio++`hpio` provides support for writing GPIO programs in Haskell. It+includes an embedded DSL for writing platform-independent programs,+along with low-level monads and IO functions which provide direct+access to each supported platform's native GPIO API.++Currently only the Linux `sysfs` GPIO filesystem is supported, but+support for other Unix GPIO platforms is planned.++For details on usage, see the included tutorial module, or the+`examples` directory in the source distribution.++[](https://travis-ci.org/dhess/hpio)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ default.nix view
@@ -0,0 +1,29 @@+{ mkDerivation, async, base, base-compat, bytestring, containers+, directory, doctest, exceptions, filepath, hlint, hspec, mtl+, mtl-compat, optparse-applicative, QuickCheck, stdenv, text+, transformers, transformers-compat, unix, unix-bytestring+}:+mkDerivation {+ pname = "hpio";+ version = "0.8.0.0";+ src = ./.;+ isLibrary = true;+ isExecutable = true;+ libraryHaskellDepends = [+ base base-compat bytestring containers directory exceptions+ filepath mtl mtl-compat QuickCheck text transformers+ transformers-compat unix unix-bytestring+ ];+ executableHaskellDepends = [+ async base base-compat exceptions mtl mtl-compat+ optparse-applicative transformers transformers-compat+ ];+ testHaskellDepends = [+ async base base-compat bytestring containers directory doctest+ exceptions filepath hlint hspec mtl mtl-compat QuickCheck text+ transformers transformers-compat unix unix-bytestring+ ];+ homepage = "https://github.com/dhess/hpio";+ description = "Monads for GPIO in Haskell";+ license = stdenv.lib.licenses.bsd3;+}
+ examples/Gpio.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (concurrently)+import Control.Monad (forever, void)+import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Foldable (for_)+import Options.Applicative+import System.GPIO.Linux.Sysfs (runSysfsGpioIO)+import System.GPIO.Monad++-- 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+ ,_trigger :: !PinInterruptMode+ ,_timeout :: !Int+ ,_outputPin :: !Pin+ ,_inputPin :: !Pin}++pollPinCmd :: Parser Command+pollPinCmd = PollPin <$> pollPinOptions++oneSecond :: Int+oneSecond = 1 * 1000000++pollPinOptions :: Parser PollPinOptions+pollPinOptions =+ PollPinOptions <$>+ option auto (long "period" <>+ short 'p' <>+ metavar "INT" <>+ value oneSecond <>+ showDefault <>+ help "Delay between output pin value toggles (in microseconds)") <*>+ option auto (long "trigger" <>+ short 't' <>+ metavar "Disabled|RisingEdge|FallingEdge|Level" <>+ value Level <>+ showDefault <>+ help "Event on which to trigger the input pin") <*>+ 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 <$>+ 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 and wait for interrupts. (Make sure the pins are connected!")))++run :: GlobalOptions -> IO ()+run (GlobalOptions SysfsIO (PollPin (PollPinOptions period trigger to inputPin outputPin))) =+ void $+ concurrently+ (void $ runSysfsGpioIO $ pollInput inputPin trigger to)+ (runSysfsGpioIO $ driveOutput outputPin period)+run (GlobalOptions SysfsIO ListPins) = runSysfsGpioIO listPins++output :: (MonadIO m) => String -> m ()+output = liftIO . putStrLn++listPins :: (Applicative m, MonadIO m, MonadGpio h m) => m ()+listPins =+ pins >>= \case+ [] -> output "No GPIO pins found on this system"+ ps -> for_ ps $ liftIO . print++pollInput :: (MonadMask m, MonadIO m, MonadGpio h m) => Pin -> PinInterruptMode -> Int -> m ()+pollInput p trigger to =+ withPin p $ \h ->+ do setPinInputMode h InputDefault+ setPinInterruptMode h trigger+ forever $+ do result <- pollPinTimeout h to+ case result of+ Nothing -> output ("readPin timed out after " ++ show to ++ " microseconds")+ Just v -> output ("Input: " ++ show v)++driveOutput :: (MonadMask m, MonadIO m, MonadGpio h m) => Pin -> Int -> m ()+driveOutput p delay =+ withPin p $ \h ->+ do setPinOutputMode h OutputDefault Low+ forever $+ do liftIO $ threadDelay delay+ v <- togglePin h+ output ("Output: " ++ show v)++main :: IO ()+main =execParser opts >>= run+ where+ opts =+ info (helper <*> cmds)+ (fullDesc <>+ progDesc "Example hpio programs." <>+ header "hpio-example - run hpio demonstrations.")
+ examples/GpioReader.hs view
@@ -0,0 +1,158 @@+{-|++This program demonstrates how to use the 'SysfsGpioT' transformer with+a transformer stack.++-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (concurrently)+import Control.Monad (forever, void)+import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)+import Data.Foldable (for_)+import Options.Applicative+import System.GPIO.Linux.Sysfs (SysfsIOT, SysfsGpioT, runSysfsGpioT, runSysfsIOT, runSysfsGpioIO)+import System.GPIO.Monad++-- 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+ ,_trigger :: !PinInterruptMode+ ,_timeout :: !Int+ ,_outputPin :: !Pin+ ,_inputPin :: !Pin}++pollPinCmd :: Parser Command+pollPinCmd = PollPin <$> pollPinOptions++oneSecond :: Int+oneSecond = 1 * 1000000++pollPinOptions :: Parser PollPinOptions+pollPinOptions =+ PollPinOptions <$>+ option auto (long "period" <>+ short 'p' <>+ metavar "INT" <>+ value oneSecond <>+ showDefault <>+ help "Delay between output pin value toggles (in microseconds)") <*>+ option auto (long "trigger" <>+ short 't' <>+ metavar "Disabled|RisingEdge|FallingEdge|Level" <>+ value Level <>+ showDefault <>+ help "Event on which to trigger the input pin") <*>+ 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 <$>+ 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 to inputPin outputPin))) =+ void $+ concurrently+ (runSysfsGpioReaderIO pollInput (Config inputPin mode to))+ (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++output :: (MonadIO m) => String -> m ()+output = liftIO . putStrLn++listPins :: (Applicative m, MonadIO m, MonadGpio h m) => m ()+listPins =+ pins >>= \case+ [] -> output "No GPIO pins found on this system"+ ps -> for_ ps $ liftIO . print++pollInput :: (MonadMask m, MonadIO m, MonadGpio h m, MonadReader Config 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 -> output ("readPin timed out after " ++ show timeout ++ " microseconds")+ Just v -> output ("Input: " ++ show v)++driveOutput :: (MonadMask m, MonadIO m, MonadGpio h m, MonadReader Config 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+ output ("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.")
+ examples/Sysfs.hs view
@@ -0,0 +1,131 @@+{-|++This program demonstrates how to use the native Linux @sysfs@ GPIO+implementation directly, without using the+'System.GPIO.Monad.MonadGpio' monad class.++-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (concurrently)+import Control.Exception (bracket_)+import Control.Monad (forever, void)+import Control.Monad.IO.Class (liftIO)+import Data.Foldable (for_)+import Options.Applicative+import System.GPIO.Linux.Sysfs.IO (SysfsIOT(..))+import System.GPIO.Linux.Sysfs.Monad+import System.GPIO.Linux.Sysfs.Types+import System.GPIO.Types++data GlobalOptions =+ GlobalOptions {_cmd :: !Command}++data Command+ = ListPins+ | ReadEdge ReadEdgeOptions++listPinsCmd :: Parser Command+listPinsCmd = pure ListPins++data ReadEdgeOptions =+ ReadEdgeOptions {_period :: !Int+ ,_edge :: !SysfsEdge+ ,_timeout :: !Int+ ,_outputPin :: !Pin+ ,_inputPin :: !Pin}++readEdgeCmd :: Parser Command+readEdgeCmd = ReadEdge <$> readEdgeOptions++oneSecond :: Int+oneSecond = 1 * 1000000++readEdgeOptions :: Parser ReadEdgeOptions+readEdgeOptions =+ ReadEdgeOptions <$>+ option auto (long "period" <>+ short 'p' <>+ metavar "INT" <>+ value oneSecond <>+ showDefault <>+ help "Delay between output pin value toggles (in microseconds)") <*>+ option auto (long "edge" <>+ short 'e' <>+ metavar "None|Rising|Falling|Both" <>+ value Both <>+ showDefault <>+ help "Edge on which to trigger the input pin") <*>+ option auto (long "timeout" <>+ short 'T' <>+ metavar "INT" <>+ value (-1) <>+ help "Use a timeout for readPin (in microseconds)") <*>+ argument auto (metavar "INPIN") <*>+ argument auto (metavar "OUTPIN")++cmds :: Parser GlobalOptions+cmds =+ GlobalOptions <$>+ hsubparser+ (command "listPins" (info listPinsCmd (progDesc "List the GPIO pins available on the system")) <>+ command "readEdge" (info readEdgeCmd (progDesc "Drive INPIN using OUTPIN. (Make sure the pins are connected!")))++type NativeSysfs a = SysfsIOT IO a++runNativeSysfs :: NativeSysfs a -> IO a+runNativeSysfs = runSysfsIOT++run :: GlobalOptions -> IO ()+run (GlobalOptions (ReadEdge (ReadEdgeOptions period edge to inputPin outputPin))) =+ void $+ concurrently+ (runNativeSysfs $ edgeRead inputPin edge to)+ (runNativeSysfs $ driveOutput outputPin period)+run (GlobalOptions ListPins) = runNativeSysfs listPins++withPin :: Pin -> NativeSysfs a -> NativeSysfs a+withPin p block = liftIO $ bracket_ (runNativeSysfs $ exportPin p) (runNativeSysfs $ unexportPin p) (runNativeSysfs block)++listPins :: NativeSysfs ()+listPins =+ availablePins >>= \case+ [] -> liftIO $ putStrLn "No GPIO pins found on this system"+ ps -> for_ ps $ liftIO . print++edgeRead :: Pin -> SysfsEdge -> Int -> NativeSysfs ()+edgeRead p edge to =+ withPin p $+ do writePinDirection p In+ writePinEdge p edge+ forever $+ do result <- pollPinValueTimeout p to+ case result of+ Nothing -> liftIO $ putStrLn ("readPin timed out after " ++ show to ++ " microseconds")+ Just v -> liftIO $ putStrLn ("Input: " ++ show v)++driveOutput :: Pin -> Int -> NativeSysfs ()+driveOutput p delay =+ withPin p $+ do writePinDirection p Out+ forever $+ do liftIO $ threadDelay delay+ v <- readPinValue p+ let notv = invertValue v+ writePinValue p notv+ liftIO $ putStrLn ("Output: " ++ show notv)++main :: IO ()+main =execParser opts >>= run+ where+ opts =+ info (helper <*> cmds)+ (fullDesc <>+ progDesc "Example sysfs hpio programs." <>+ header "hpio-sysfs-example - run sysfs hpio demonstrations.")
+ hpio.cabal view
@@ -0,0 +1,253 @@+Name: hpio+Version: 0.8.0.0+Cabal-Version: >= 1.10+Build-Type: Simple+Author: Drew Hess <src@drewhess.com>+Maintainer: Drew Hess <src@drewhess.com>+Homepage: https://github.com/dhess/hpio+Bug-Reports: https://github.com/dhess/hpio/issues/+Stability: experimental+License: BSD3+License-File: LICENSE+Copyright: Copyright (c) 2016, Drew Hess+Tested-With: GHC == 7.8.4, GHC == 7.10.2, GHC == 7.10.3, GHC == 8.0.1+Category: System+Synopsis: Monads for GPIO in Haskell+Description:+ This package provides an embedded DSL for writing cross-platform+ GPIO programs in Haskell. Currently only Linux is supported (via the+ @sysfs@ filesystem), but other Unix GPIO platforms will be supported+ in the future.+ .+ Monads and low-level actions are also provided for each supported+ platform's native GPIO API, if you want to program directly to+ the platform API.+ .+ Example programs are provided in the 'examples' directory of the+ source code distribution. There is also a "System.GPIO.Tutorial"+ module, which explains how to use the cross-platform DSL.+Extra-Doc-Files: README.md+Extra-Source-Files: .travis.yml+ , Hlint.hs+ , default.nix+ , shell.nix+ , stack.yaml+ , stack-lts-2.yaml++-- Enable Linux BeagleBone-specific tests. See+-- test/System/GPIO/Linux/Sysfs/BeagleBoneSpec.hs for requirements.+--+-- > cabal test -flinux-bbone-tests+Flag linux-bbone-tests+ Default: False+ Manual: True++-- Build doctests+Flag test-doctests+ Default: True+ Manual: True++-- Build hlint test+Flag test-hlint+ Default: True+ Manual: True++-- Build the example programs+Flag examples+ Default: True+ Manual: True++Library+ Default-Language: Haskell2010+ HS-Source-Dirs: src+ GHC-Options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates+ If impl(ghc > 8)+ GHC-Options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances -fno-warn-redundant-constraints+ Exposed-Modules: System.GPIO+ , System.GPIO.Linux+ , System.GPIO.Linux.Sysfs+ , System.GPIO.Linux.Sysfs.IO+ , System.GPIO.Linux.Sysfs.Monad+ , System.GPIO.Linux.Sysfs.Mock+ , System.GPIO.Linux.Sysfs.Types+ , System.GPIO.Linux.Sysfs.Util+ , System.GPIO.Monad+ , System.GPIO.Tutorial+ , System.GPIO.Types+ Other-Modules: System.GPIO.Linux.Sysfs.Mock.Internal+ Other-Extensions: CPP+ , DeriveDataTypeable+ , DeriveGeneric+ , ExistentialQuantification+ , FlexibleContexts+ , FlexibleInstances+ , FunctionalDependencies+ , GADTs+ , GeneralizedNewtypeDeriving+ , InterruptibleFFI+ , KindSignatures+ , LambdaCase+ , MultiParamTypeClasses+ , OverloadedStrings+ , PackageImports+ , QuasiQuotes+ , Safe+ , TemplateHaskell+ , Trustworthy+ , TypeSynonymInstances+ , UndecidableInstances+ Build-Depends: QuickCheck >= 2.7.6 && < 2.9+ , base >= 4.7.0 && < 5+ , base-compat >= 0.6.0 && < 1+ , bytestring >= 0.10.4 && < 0.11+ , containers >= 0.5.5 && < 0.6+ , directory >= 1.2.1 && < 1.3+ , exceptions >= 0.8.0 && < 1+ , filepath >= 1.3.0 && < 1.5+ , mtl >= 2.1.3 && < 2.3+ , mtl-compat >= 0.2.1 && < 0.3+ , text >= 1.2.0 && < 1.3+ , transformers >= 0.3.0 && < 0.6+ , transformers-compat >= 0.4.0 && < 1+ , unix >= 2.7.0 && < 2.8+ , unix-bytestring >= 0.3.7 && < 0.4+ C-Sources: src/System/GPIO/Linux/Sysfs/pollSysfs.c+ CC-Options: -Wall++Executable hpio-sysfs-example+ Main-Is: Sysfs.hs+ HS-Source-Dirs: examples+ If !flag(examples)+ Buildable: False+ Else+ Build-Depends: base+ , async >= 2.0.2 && < 2.2+ , base-compat+ , hpio+ , mtl+ , mtl-compat+ , optparse-applicative >= 0.11.0 && < 0.13+ , transformers+ , transformers-compat+ Default-Language: Haskell2010+ Ghc-Options: -Wall -threaded++Executable hpio-example+ Main-Is: Gpio.hs+ HS-Source-Dirs: examples+ If !flag(examples)+ Buildable: False+ Else+ Build-Depends: base+ , async+ , base-compat+ , exceptions+ , hpio+ , mtl+ , mtl-compat+ , optparse-applicative+ , transformers+ , transformers-compat+ Default-Language: Haskell2010+ Ghc-Options: -Wall -threaded+ If impl(ghc > 8)+ GHC-Options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances -fno-warn-redundant-constraints -fno-warn-redundant-constraints++Executable hpio-reader-example+ Main-Is: GpioReader.hs+ HS-Source-Dirs: examples+ If !flag(examples)+ Buildable: False+ Else+ Build-Depends: base+ , async+ , base-compat+ , exceptions+ , hpio+ , mtl+ , mtl-compat+ , optparse-applicative+ , transformers+ , transformers-compat++ Default-Language: Haskell2010+ Ghc-Options: -Wall -threaded+ If impl(ghc > 8)+ GHC-Options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances -fno-warn-redundant-constraints -fno-warn-redundant-constraints++Test-Suite hlint+ Type: exitcode-stdio-1.0+ Default-Language: Haskell2010+ Hs-Source-Dirs: test+ Ghc-Options: -w -threaded+ Main-Is: hlint.hs+ If !flag(test-hlint)+ Buildable: False+ Else+ Build-Depends: base+ , hlint++Test-Suite doctest+ Type: exitcode-stdio-1.0+ Default-Language: Haskell2010+ Hs-Source-Dirs: test+ Ghc-Options: -Wall -threaded+ Main-Is: doctest.hs+ -- Disabled on GHC 7.8.x and earlier due to missing Data.Bits bits.+ If !flag(test-doctests) || impl(ghc < 7.10)+ Buildable: False+ Else+ Build-Depends: base+ , doctest+ , filepath++Test-Suite spec+ Type: exitcode-stdio-1.0+ Default-Language: Haskell2010+ Hs-Source-Dirs: src+ , test+ Ghc-Options: -Wall -threaded+ If impl(ghc > 8)+ GHC-Options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances -fno-warn-redundant-constraints -fno-warn-redundant-constraints+ Main-Is: Main.hs+ Build-Depends: QuickCheck+ , base+ , async+ , base-compat+ , bytestring+ , containers+ , directory+ , exceptions+ , filepath+ , hspec >= 2.1.7 && < 2.3+ , mtl+ , mtl-compat+ , text+ , transformers+ , transformers-compat+ , unix+ , unix-bytestring+ Other-modules: System.GPIO+ , System.GPIO.Linux+ , System.GPIO.Linux.Sysfs+ , System.GPIO.Linux.Sysfs.IO+ , System.GPIO.Linux.Sysfs.Monad+ , System.GPIO.Linux.Sysfs.Mock+ , System.GPIO.Linux.Sysfs.Mock.Internal+ , System.GPIO.Linux.Sysfs.Types+ , System.GPIO.Linux.Sysfs.Util+ , System.GPIO.Monad+ , System.GPIO.Tutorial+ , System.GPIO.Types+ C-Sources: src/System/GPIO/Linux/Sysfs/pollSysfs.c+ If flag(linux-bbone-tests)+ cpp-options: -DRUN_LINUX_BBONE_TESTS=1++Source-Repository head+ Type: git+ Location: git://github.com/dhess/hpio.git++Source-Repository this+ Type: git+ Location: git://github.com/dhess/hpio.git+ Tag: v0.8.0.0
+ shell.nix view
@@ -0,0 +1,45 @@+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default" }:++let++ inherit (nixpkgs) pkgs;++ f = { mkDerivation, async, base, base-compat, bytestring+ , containers, directory, doctest, exceptions, filepath, hlint+ , hspec, mtl, mtl-compat, optparse-applicative, QuickCheck, stdenv+ , text, transformers, transformers-compat, unix, unix-bytestring+ }:+ mkDerivation {+ pname = "hpio";+ version = "0.8.0.0";+ src = ./.;+ isLibrary = true;+ isExecutable = true;+ libraryHaskellDepends = [+ base base-compat bytestring containers directory exceptions+ filepath mtl mtl-compat QuickCheck text transformers+ transformers-compat unix unix-bytestring+ ];+ executableHaskellDepends = [+ async base base-compat exceptions mtl mtl-compat+ optparse-applicative transformers transformers-compat+ ];+ testHaskellDepends = [+ async base base-compat bytestring containers directory doctest+ exceptions filepath hlint hspec mtl mtl-compat QuickCheck text+ transformers transformers-compat unix unix-bytestring+ ];+ homepage = "https://github.com/dhess/hpio";+ description = "Monads for GPIO in Haskell";+ license = stdenv.lib.licenses.bsd3;+ };++ haskellPackages = if compiler == "default"+ then pkgs.haskellPackages+ else pkgs.haskell.packages.${compiler};++ drv = haskellPackages.callPackage f {};++in++ if pkgs.lib.inNixShell then drv.env else drv
+ src/System/GPIO.hs view
@@ -0,0 +1,24 @@+{-|+Module : System.GPIO+Description : Top-level re-exports for writing GPIO programs+Copyright : (c) 2016, Drew Hess+License : BSD3+Maintainer : Drew Hess <src@drewhess.com>+Stability : experimental+Portability : non-portable++Top-level re-exports for writing GPIO programs.++-}++{-# LANGUAGE Safe #-}++module System.GPIO+ ( -- * The MonadGpio class+ module System.GPIO.Monad+ -- * GPIO in Linux+ , module System.GPIO.Linux+ ) where++import System.GPIO.Monad+import System.GPIO.Linux
+ src/System/GPIO/Linux.hs view
@@ -0,0 +1,27 @@+{-|+Module : System.GPIO.Linux+Description : Linux GPIO+Copyright : (c) 2016, Drew Hess+License : BSD3+Maintainer : Drew Hess <src@drewhess.com>+Stability : experimental+Portability : non-portable++Linux GPIO.++Currently, this module is rather redundant, as it only re-exports the+top-level Linux @sysfs@ GPIO module. That's because @sysfs@ GPIO is+the only built-in GPIO implementation that the Linux kernel currently+supports. However, if future Linux kernels provide a new GPIO system,+that implementation would presumably also be exported from here.++-}++{-# LANGUAGE Safe #-}++module System.GPIO.Linux+ ( -- * Linux @sysfs@ GPIO+ module System.GPIO.Linux.Sysfs+ ) where++import System.GPIO.Linux.Sysfs
+ src/System/GPIO/Linux/Sysfs.hs view
@@ -0,0 +1,115 @@+{-|+Module : System.GPIO.Linux.Sysfs+Description : GPIO in Linux via the @sysfs@ filesystem+Copyright : (c) 2016, Drew Hess+License : BSD3+Maintainer : Drew Hess <src@drewhess.com>+Stability : experimental+Portability : non-portable++GPIO in Linux via the @sysfs@ filesystem.++See the <https://www.kernel.org/doc/Documentation/gpio/sysfs.txt Linux kernel documentation>+for the definitive description of the Linux @sysfs@-based GPIO API and+the terminology used in this module.++== Pin numbering++The @sysfs@ GPIO implementation in this module uses the same pin+numbering scheme as the @sysfs@ GPIO filesystem. For example,+'System.GPIO.Types.Pin' @13@ corresponds to @gpio13@ in the @sysfs@+filesystem. Note that the @sysfs@ pin numbering scheme is almost+always different than the pin numbering scheme given by the+platform/hardware documentation. Consult your platform documentation+for the mapping of pin numbers between the two namespaces.++-}++{-# LANGUAGE Safe #-}++module System.GPIO.Linux.Sysfs+ ( -- * The Linux @sysfs@ GPIO interpreter+ --+ -- | The 'SysfsGpioT' monad transformer provides an instance+ -- of the 'System.GPIO.Monad.MonadGpio' monad type class for+ -- running GPIO computations on a Linux host via the @sysfs@+ -- GPIO filesystem.+ --+ -- The implementation abstracts back-end @sysfs@ filesystem+ -- operations via the+ -- 'System.GPIO.Linux.Sysfs.Monad.MonadSysfs' monad type+ -- class. Primarily, this abstraction exists in order to more+ -- easily test @sysfs@ GPIO programs on non-Linux systems, or+ -- on Linux systems which lack actual GPIO functionality. To+ -- run GPIO programs on real GPIO-capable Linux systems,+ -- you'll want to combine the 'SysfsGpioT' transformer with+ -- the 'SysfsIOT' monad transformer. For the straightforward+ -- case of running @sysfs@ GPIO operations directly in 'IO',+ -- use the provided 'runSysfsGpioIO' wrapper; for more+ -- complicated transformer stacks, compose the+ -- 'runSysfsGpioT' and 'runSysfsIOT' wrappers. (See the+ -- "System.GPIO.Tutorial" module for details.)+ --+ -- For testing purposes, you can use the+ -- 'System.GPIO.Linux.Sysfs.Mock.SysfsMock' monad (or its+ -- corresponding 'System.GPIO.Linux.Sysfs.Mock.SysfsMockT'+ -- monad transformer) as the @sysfs@ back-end, which allows+ -- you to run (mock) GPIO programs on any system. Note that+ -- the testing monads are not exported from this module; you+ -- must import the "System.GPIO.Linux.Sysfs.Mock" module+ -- directly.+ SysfsGpioT+ , runSysfsGpioT+ , SysfsGpioIO+ , runSysfsGpioIO+ , PinDescriptor(..)+ -- * The Linux @sysfs@ monad+ --+ , MonadSysfs(..)+ , SysfsIOT(..)+ -- * Low-level @sysfs@ GPIO actions+ --+ -- | A slightly more low-level API is also available if you+ -- want to write directly to the Linux @sysfs@ GPIO+ -- filesystem, or do something that the+ -- 'System.GPIO.Monad.MonadGpio' portable GPIO interface+ -- doesn't allow you to express.+ , sysfsIsPresent+ , availablePins+ , pinIsExported+ , exportPin+ , exportPinChecked+ , unexportPin+ , unexportPinChecked+ , pinHasDirection+ , readPinDirection+ , writePinDirection+ , writePinDirectionWithValue+ , readPinValue+ , pollPinValue+ , pollPinValueTimeout+ , writePinValue+ , pinHasEdge+ , readPinEdge+ , writePinEdge+ , readPinActiveLow+ , writePinActiveLow+ -- * @sysfs@-specific types+ , SysfsEdge(..)+ , toPinInterruptMode+ , toSysfsEdge+ -- * @sysfs@-specific Exceptions+ , SysfsException(..)+ ) where++import System.GPIO.Linux.Sysfs.Monad+import System.GPIO.Linux.Sysfs.IO+import System.GPIO.Linux.Sysfs.Types++-- | A specialization of 'SysfsGpioT' which runs GPIO computations in+-- 'IO' via @sysfs@.+type SysfsGpioIO = SysfsGpioT (SysfsIOT IO)++-- | Run GPIO computations in 'IO' via @sysfs@.+runSysfsGpioIO :: SysfsGpioIO a -> IO a+runSysfsGpioIO action = runSysfsIOT $ runSysfsGpioT action
+ src/System/GPIO/Linux/Sysfs/IO.hs view
@@ -0,0 +1,104 @@+{-|+Module : System.GPIO.Linux.Sysfs.IO+Description : Linux @sysfs@ GPIO operations in IO+Copyright : (c) 2016, Drew Hess+License : BSD3+Maintainer : Drew Hess <src@drewhess.com>+Stability : experimental+Portability : non-portable++The actual Linux @sysfs@ implementation. This implementation will only+function properly on Linux systems with a @sysfs@ subsystem,+obviously.++-}++{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InterruptibleFFI #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE Trustworthy #-}++module System.GPIO.Linux.Sysfs.IO+ ( -- * SysfsIOT transformer+ SysfsIOT(..)+ ) where++import Prelude ()+import Prelude.Compat+import Control.Applicative (Alternative)+import Control.Monad (MonadPlus, void)+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, bracket)+import Control.Monad.Cont (MonadCont)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Except (MonadError)+import Control.Monad.Fix (MonadFix)+import Control.Monad.Reader (MonadReader)+import Control.Monad.RWS (MonadRWS)+import Control.Monad.State (MonadState)+import Control.Monad.Trans.Class (MonadTrans, lift)+import Control.Monad.Writer (MonadWriter)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS (readFile, writeFile)+import Foreign.C.Error (throwErrnoIfMinus1Retry)+import Foreign.C.Types (CInt(..))+import qualified System.Directory as D (doesDirectoryExist, doesFileExist, getDirectoryContents)+import "unix" System.Posix.IO (OpenMode(ReadOnly, WriteOnly), closeFd, defaultFileFlags, openFd)+import "unix-bytestring" System.Posix.IO.ByteString (fdWrite)++import System.GPIO.Linux.Sysfs.Monad (MonadSysfs(..))++-- | An instance of 'MonadSysfs' which runs 'MonadSysfs' operations in+-- IO. This instance must be run on an actual Linux @sysfs@ GPIO+-- filesystem and will fail in any other environment.+--+-- == Interactions with threads+--+-- Some parts of this implementation use the Haskell C FFI, and may+-- block on C I/O operations. (Specifically, 'pollFile' will block in+-- the C FFI until its event is triggered.) When using this+-- implementation with GHC, you should compile your program with the+-- @-threaded@ option, so that threads performing these blocking+-- operations do not block other Haskell threads in the system.+--+-- Note that the C FFI bits in this implementation are marked as+-- 'interruptible', so that, on versions of GHC later than 7.8.1,+-- functions such as 'Control.Concurent.throwTo' will work properly+-- when targeting a Haskell thread that uses this implementation.+--+-- (On Haskell implementations other than GHC, the threading+-- implications are unknown; see the implementation's notes on how its+-- threading system interacts with the C FFI.)+newtype SysfsIOT m a =+ SysfsIOT { runSysfsIOT :: m a }+ deriving (Functor,Alternative,Applicative,Monad,MonadFix,MonadPlus,MonadThrow,MonadCatch,MonadMask,MonadCont,MonadIO,MonadReader r,MonadError e,MonadWriter w,MonadState s,MonadRWS r w s)++instance MonadTrans SysfsIOT where+ lift = SysfsIOT++instance (MonadIO m, MonadThrow m) => MonadSysfs (SysfsIOT m) where+ doesDirectoryExist = liftIO . D.doesDirectoryExist+ doesFileExist = liftIO . D.doesFileExist+ getDirectoryContents = liftIO . D.getDirectoryContents+ readFile = liftIO . BS.readFile+ writeFile fn bs = liftIO $ BS.writeFile fn bs+ unlockedWriteFile fn bs = liftIO $ unlockedWriteFileIO fn bs+ pollFile fn timeout = liftIO $ pollFileIO fn timeout++unlockedWriteFileIO :: FilePath -> ByteString -> IO ()+unlockedWriteFileIO fn bs =+ bracket+ (openFd fn WriteOnly Nothing defaultFileFlags)+ closeFd+ (\fd -> void $ fdWrite fd bs)++foreign import ccall interruptible "pollSysfs" pollSysfs :: CInt -> CInt -> IO CInt++pollFileIO :: FilePath -> Int -> IO CInt+pollFileIO fn timeout =+ bracket+ (openFd fn ReadOnly Nothing defaultFileFlags)+ closeFd+ (\fd -> throwErrnoIfMinus1Retry "pollSysfs" $ pollSysfs (fromIntegral fd) (fromIntegral timeout))
+ src/System/GPIO/Linux/Sysfs/Mock.hs view
@@ -0,0 +1,708 @@+{-|+Module : System.GPIO.Linux.Sysfs.Mock+Description : A mock MonadSysfs instance.+Copyright : (c) 2016, Drew Hess+License : BSD3+Maintainer : Drew Hess <src@drewhess.com>+Stability : experimental+Portability : non-portable++A mock 'M.MonadSysfs' instance, for testing GPIO programs.++Note that this monad only mocks the subset of @sysfs@ functionality+required for GPIO programs. It does not mock the entire @sysfs@+filesystem.++-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Trustworthy #-}++module System.GPIO.Linux.Sysfs.Mock+ ( -- * SysfsMock types+ MockWorld+ , MockPinState(..)+ , defaultMockPinState+ , logicalValue+ , setLogicalValue+ , MockGpioChip(..)+ , MockPins+ , mockWorldPins+ , initialMockWorld+ -- * The SysfsMock monad+ , SysfsMockT(..)+ , runSysfsMockT+ , evalSysfsMockT+ , execSysfsMockT+ -- * Run mock GPIO computations+ , SysfsGpioMock+ , runSysfsGpioMock+ , evalSysfsGpioMock+ , execSysfsGpioMock+ , SysfsGpioMockIO+ , runSysfsGpioMockIO+ , evalSysfsGpioMockIO+ , execSysfsGpioMockIO+ -- * Mock @sysfs@ exceptions.+ , MockFSException(..)+ -- * Run mock @sysfs@ computations.+ --+ -- | Generally speaking, you should not need to use these+ -- types, as they're not very useful on their own. They are+ -- primarily exported for unit testing.+ --+ -- If you want to run mock GPIO computations, use+ -- 'SysfsMockT' for buildling transformer stacks, or either+ -- 'SysfsGpioMock' or 'SysfsGpioMockIO' for simple+ -- computations that are pure or mix with 'IO', respectively.+ , SysfsMock+ , runSysfsMock+ , evalSysfsMock+ , execSysfsMock+ , SysfsMockIO+ , runSysfsMockIO+ , evalSysfsMockIO+ , execSysfsMockIO+ -- * Mock @sysfs@ actions+ --+ -- | Generally speaking, you should not need these actions.+ -- They are primarily exported for unit testing.+ , doesDirectoryExist+ , doesFileExist+ , getDirectoryContents+ , readFile+ , writeFile+ , unlockedWriteFile+ , pollFile+ ) where++import Prelude ()+import Prelude.Compat hiding (readFile, writeFile)+import Control.Applicative (Alternative)+import Control.Exception (Exception(..), SomeException)+import Control.Monad (MonadPlus, when)+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, throwM)+import Control.Monad.Catch.Pure (Catch, runCatch)+import Control.Monad.Cont (MonadCont)+import Control.Monad.Except (MonadError)+import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Reader (MonadReader(..))+import Control.Monad.State.Strict (MonadState(..), StateT(..), gets, execStateT)+import Control.Monad.Trans.Class (MonadTrans)+import Control.Monad.Writer (MonadWriter(..))+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as C8 (pack, unlines)+import Data.Foldable (foldrM)+import Data.Maybe (isJust)+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map (empty, insert, insertLookupWithKey, lookup)+import Data.Typeable (Typeable)+import Foreign.C.Types (CInt(..))+import GHC.IO.Exception (IOErrorType(..))+import System.FilePath ((</>), splitFileName)+import System.IO.Error (mkIOError)++import System.GPIO.Linux.Sysfs.Mock.Internal+ (Directory, File(..), FileType(..), MockFSZipper(..), directory,+ dirName, files, subdirs, findFile)+import qualified System.GPIO.Linux.Sysfs.Mock.Internal as Internal+ (cd, mkdir, mkfile, pathFromRoot, rmdir)+import System.GPIO.Linux.Sysfs.Monad (SysfsGpioT(..))+import qualified System.GPIO.Linux.Sysfs.Monad as M (MonadSysfs(..))+import System.GPIO.Linux.Sysfs.Types (SysfsEdge(..))+import System.GPIO.Linux.Sysfs.Util+ (bsToInt, intToBS, pinActiveLowFileName, pinDirectionFileName,+ pinEdgeFileName, pinValueFileName, pinDirName, activeLowToBS,+ bsToActiveLow, pinDirectionToBS, bsToPinDirection, sysfsEdgeToBS,+ bsToSysfsEdge, pinValueToBS, bsToPinValue, sysfsPath)+import System.GPIO.Types+ (Pin(..), PinDirection(..), PinValue(..), gpioExceptionToException,+ gpioExceptionFromException, invertValue)++-- | A mock pin.+data MockPinState =+ MockPinState {_direction :: !PinDirection+ -- ^ The pin's direction+ ,_userVisibleDirection :: !Bool+ -- ^ Is the pin's direction visible from the filesystem?+ ,_activeLow :: !Bool+ -- ^ Is the pin configured as active-low?+ ,_value :: !PinValue+ -- ^ The pin's /physical/ signal level+ ,_edge :: Maybe SysfsEdge+ -- ^ The pin's interrupt mode (if supported)+ }+ deriving (Show,Eq)++-- | Linux @sysfs@ GPIO natively supports active-low logic levels. A+-- pin's "active" level is controlled by the pin's @active_low@+-- attribute. The pin's value relative to its @active_low@ attribute+-- is called its /logical value/. This function returns the mock pin's+-- logical value.+--+-- >>> logicalValue defaultMockPinState+-- Low+-- >>> logicalValue defaultMockPinState { _value = High }+-- High+-- >>> logicalValue defaultMockPinState { _activeLow = True }+-- High+-- >>> logicalValue defaultMockPinState { _activeLow = True, _value = High }+-- Low+logicalValue :: MockPinState -> PinValue+logicalValue s+ | _activeLow s = invertValue $ _value s+ | otherwise = _value s++-- | This function sets the 'MockPinState' signal level to the given+-- /logical/ value.+--+-- >>> _value $ setLogicalValue High defaultMockPinState+-- High+-- >>> _value $ setLogicalValue High defaultMockPinState { _activeLow = True }+-- Low+setLogicalValue :: PinValue -> MockPinState -> MockPinState+setLogicalValue v s+ | _activeLow s = s {_value = invertValue v}+ | otherwise = s {_value = v}++-- | Default initial state of mock pins.+--+-- >>> defaultMockPinState+-- MockPinState {_direction = Out, _userVisibleDirection = True, _activeLow = False, _value = Low, _edge = Just None}+defaultMockPinState :: MockPinState+defaultMockPinState =+ MockPinState {_direction = Out+ ,_userVisibleDirection = True+ ,_activeLow = False+ ,_value = Low+ ,_edge = Just None}++-- | A mock GPIO "chip." In the Linux @sysfs@ GPIO filesystem, a GPIO+-- chip is a set of one or more GPIO pins.+--+-- Note that the '_initialPinStates' list is used to construct the pin+-- state for a 'MockWorld' (see 'runSysfsMockT'). For each+-- 'MockPinState' value in the list, a mock pin will be created in the+-- mock filesystem such that, when that pin is exported, its path is+-- @\/sys\/class\/gpio\/gpioN@, where @N@ is @_base@ + the pin's index+-- in the '_initialPinStates' list.+data MockGpioChip =+ MockGpioChip {_label :: !String+ -- ^ The name given to the chip in the filesystem+ ,_base :: !Int+ -- ^ The pin number of the chip's first pin+ ,_initialPinStates :: [MockPinState]+ -- ^ The pins' initial states+ }+ deriving (Show,Eq)++-- | A type alias for a strict map of 'Pin' to its 'MockPinState'.+type MockPins = Map Pin MockPinState++-- | The global state of a mock Linux GPIO subsystem with a @sysfs@+-- interface. It consists of the mock @sysfs@ GPIO filesystem state,+-- along with the state of every mock pin.+--+-- An actual Linux @sysfs@ GPIO filesystem is not like a+-- general-purpose filesystem. The user cannot create files or+-- directories directly; they can only be created (or modified) via+-- prescribed operations on special conrol files, which are themselves+-- created by the kernel.+--+-- Likewise, the kernel and hardware platform together determine which+-- GPIO pins are exposed to the user via the @sysfs@ GPIO filesystem.+--+-- To preserve the illusion of an actual @sysfs@ GPIO filesystem, the+-- 'MockWorld' type is opaque and can only be manipulated via the+-- handful of actions that are implemented in this module. These+-- actions have been designed to keep the internal state of the mock+-- @sysfs@ GPIO filesystem consistent with the behavior that would be+-- seen in an actual @sysfs@ GPIO filesystem.+--+-- The high/low signal level on a real GPIO pin can, of course, be+-- manipulated by the circuit to which the pin is conected. A future+-- version of this implementation may permit the direct manipulation+-- of mock pin values in order to simulate simple circuits, but+-- currently the only way to manipulate pin state is via the mock+-- @sysfs@ GPIO filesystem.+data MockWorld =+ MockWorld {_zipper :: MockFSZipper+ ,_pins :: MockPins}+ deriving (Show,Eq)++-- | Get the pin map from a 'MockWorld'.+mockWorldPins :: MockWorld -> MockPins+mockWorldPins = _pins++-- | The initial 'MockWorld', representing a @sysfs@ filesystem with+-- no pins.+initialMockWorld :: MockWorld+initialMockWorld = MockWorld sysfsRootZipper Map.empty++-- | A monad transformer which adds mock @sysfs@ computations to an+-- inner monad 'm'.+newtype SysfsMockT m a =+ SysfsMockT {unSysfsMockT :: StateT MockWorld m a}+ deriving (Functor,Alternative,Applicative,Monad,MonadFix,MonadPlus,MonadThrow,MonadCatch,MonadMask,MonadCont,MonadIO,MonadReader r,MonadError e,MonadWriter w,MonadState MockWorld,MonadTrans)++getZipper :: (Monad m) => SysfsMockT m MockFSZipper+getZipper = gets _zipper++putZipper :: (Monad m) => MockFSZipper -> SysfsMockT m ()+putZipper z =+ do s <- get+ put $ s {_zipper = z}++getPins :: (Monad m) => SysfsMockT m MockPins+getPins = gets _pins++pinState :: (Functor m, MonadThrow m) => Pin -> SysfsMockT m MockPinState+pinState pin =+ Map.lookup pin <$> getPins >>= \case+ Nothing -> throwM $ InternalError ("An operation attempted to get the mock pin state for non-existent pin " ++ show pin)+ Just s -> return s++putPins :: (Monad m) => MockPins -> SysfsMockT m ()+putPins ps =+ do s <- get+ put $ s {_pins = ps}++putPinState :: (Functor m, MonadThrow m) => Pin -> (MockPinState -> MockPinState) -> SysfsMockT m ()+putPinState pin f =+ do ps <- pinState pin+ (Map.insert pin (f ps) <$> getPins) >>= putPins++-- | Run a mock @sysfs@ computation in monad 'm' with an initial mock+-- world and list of 'MockGpioChip's; and return a tuple containing the+-- computation's value and the final 'MockWorld'. If an exception+-- occurs in the mock computation, a 'MockFSException' is thrown.+--+-- Before running the computation, the 'MockWorld' is populated with+-- the GPIO pins as specified by the list of 'MockGpioChip's. If any+-- of the chips' pin ranges overlap, a 'MockFSException' is thrown.+--+-- Typically, you will only need this action if you're trying to mock+-- Linux @sysfs@ GPIO computations using a custom monad transformer+-- stack. For simple cases, see 'runSysfsGpioMock' or+-- 'runSysfsGpioMockIO'.+runSysfsMockT :: (Functor m, MonadThrow m) => SysfsMockT m a -> MockWorld -> [MockGpioChip] -> m (a, MockWorld)+runSysfsMockT action world chips =+ do startState <- execStateT (unSysfsMockT $ pushd "/" (makeFileSystem chips)) world+ runStateT (unSysfsMockT action) startState++-- | Like 'runSysfsMockT', but returns only the computation's value.+evalSysfsMockT :: (Functor m, MonadThrow m) => SysfsMockT m a -> MockWorld -> [MockGpioChip] -> m a+evalSysfsMockT a w chips = fst <$> runSysfsMockT a w chips++-- | Like 'runSysfsMockT', but returns only the final 'MockWorld'.+execSysfsMockT :: (Functor m, MonadThrow m) => SysfsMockT m a -> MockWorld -> [MockGpioChip] -> m MockWorld+execSysfsMockT a w chips = snd <$> runSysfsMockT a w chips++instance (Functor m, MonadThrow m) => M.MonadSysfs (SysfsMockT m) where+ doesDirectoryExist = doesDirectoryExist+ doesFileExist = doesFileExist+ getDirectoryContents = getDirectoryContents+ readFile = readFile+ writeFile = writeFile+ unlockedWriteFile = unlockedWriteFile+ pollFile = pollFile++-- | The simplest possible (pure) mock @sysfs@ monad.+--+-- NB: this monad /cannot/ run GPIO computations; its only use is to+-- mock @sysfs@ operations on an extremely limited mock @sysfs@+-- simulator.+--+-- You probably do not want to use this monad; see either+-- 'SysfsGpioMock' or 'SysfsGpioMockIO', which adds GPIO computations+-- to this mock @sysfs@ environment.+type SysfsMock = SysfsMockT Catch++-- | A pure version of 'runSysfsMockT' which returns errors in a+-- 'Left', and both the computation's value and the final state of the+-- 'MockWorld' in a 'Right'.+--+-- >>> let mockChip = MockGpioChip "chip0" 0 (replicate 16 defaultMockPinState)+-- >>> fst <$> runSysfsMock (getDirectoryContents "/sys/class/gpio") initialMockWorld [mockChip]+-- Right ["gpiochip0","export","unexport"]+-- >>> runSysfsMock (getDirectoryContents "/sys/class/does_not_exist") initialMockWorld [mockChip]+-- Left /sys/class/does_not_exist: Mock.Internal.cd: does not exist+runSysfsMock :: SysfsMock a -> MockWorld -> [MockGpioChip] -> Either SomeException (a, MockWorld)+runSysfsMock a w chips = runCatch $ runSysfsMockT a w chips++-- | Like 'runSysfsMock', but returns only the computation's value.+evalSysfsMock :: SysfsMock a -> MockWorld -> [MockGpioChip] -> Either SomeException a+evalSysfsMock a w chips = fst <$> runSysfsMock a w chips++-- | Like 'runSysfsMock', but returns only the final 'MockWorld'.+execSysfsMock :: SysfsMock a -> MockWorld -> [MockGpioChip] -> Either SomeException MockWorld+execSysfsMock a w chips = snd <$> runSysfsMock a w chips++-- | A specialization of 'SysfsGpioT' which runs (pure, fake) GPIO+-- computations via a mock @sysfs@.+type SysfsGpioMock = SysfsGpioT SysfsMock++-- | Run a 'SysfsGpioMock' computation with an initial mock world and+-- list of 'MockGpioChip's, and return a tuple containing the+-- computation's value and the final 'MockWorld'. Any exceptions that+-- occur in the mock computation are returned as a 'Left' value.+--+-- Before running the computation, the 'MockWorld' is populated with+-- the GPIO pins as specified by the list of 'MockGpioChip's. If any+-- of the chips' pin ranges overlap, a 'MockFSException' is returned+-- in a 'Left' value.+--+-- >>> import System.GPIO.Monad+-- >>> let mockChip = MockGpioChip "chip0" 0 (replicate 16 defaultMockPinState)+-- >>> fst <$> runSysfsGpioMock pins initialMockWorld [mockChip]+-- Right [Pin 0,Pin 1,Pin 2,Pin 3,Pin 4,Pin 5,Pin 6,Pin 7,Pin 8,Pin 9,Pin 10,Pin 11,Pin 12,Pin 13,Pin 14,Pin 15]+-- >>> fst <$> runSysfsGpioMock (openPin (Pin 32)) initialMockWorld [mockChip]+-- Left InvalidPin (Pin 32)+runSysfsGpioMock :: SysfsGpioMock a -> MockWorld -> [MockGpioChip] -> Either SomeException (a, MockWorld)+runSysfsGpioMock a = runSysfsMock (runSysfsGpioT a)++-- | Like 'runSysfsGpioMock', but returns only the computation's+-- value.+evalSysfsGpioMock :: SysfsGpioMock a -> MockWorld -> [MockGpioChip] -> Either SomeException a+evalSysfsGpioMock a = evalSysfsMock (runSysfsGpioT a)++-- | Like 'runSysfsGpioMock', but returns only the final 'MockWorld'.+execSysfsGpioMock :: SysfsGpioMock a -> MockWorld -> [MockGpioChip] -> Either SomeException MockWorld+execSysfsGpioMock a = execSysfsMock (runSysfsGpioT a)++-- | The simplest possible ('IO'-enabled) mock @sysfs@ monad. Like+-- 'SysfsMock', but allows you to mix 'IO' operations into your+-- @sysfs@ computations, as well.+--+-- NB: this monad /cannot/ run GPIO computations; its only use is to+-- mock @sysfs@ operations on an extremely limited mock @sysfs@+-- simulator.+--+-- You probably do not want to use this monad; see either+-- 'SysfsGpioMock' or 'SysfsGpioMockIO', which adds GPIO computations+-- to this mock @sysfs@ environment.+type SysfsMockIO = SysfsMockT IO++-- | An 'IO' version of 'runSysfsMockT'. Errors are expressed as+-- exceptions.+--+-- >>> let mockChip = MockGpioChip "chip0" 0 (replicate 16 defaultMockPinState)+-- >>> fst <$> runSysfsMockIO (getDirectoryContents "/sys/class/gpio") initialMockWorld [mockChip]+-- ["gpiochip0","export","unexport"]+-- >>> runSysfsMockIO (getDirectoryContents "/sys/class/does_not_exist") initialMockWorld [mockChip]+-- *** Exception: /sys/class/does_not_exist: Mock.Internal.cd: does not exist+runSysfsMockIO :: SysfsMockIO a -> MockWorld -> [MockGpioChip] -> IO (a, MockWorld)+runSysfsMockIO = runSysfsMockT++-- | Like 'runSysfsMockIO', but returns only the computation's value.+evalSysfsMockIO :: SysfsMockIO a -> MockWorld -> [MockGpioChip] -> IO a+evalSysfsMockIO a w chips = fst <$> runSysfsMockIO a w chips++-- | Like 'runSysfsMockIO', but returns only the final 'MockWorld'.+execSysfsMockIO :: SysfsMockIO a -> MockWorld -> [MockGpioChip] -> IO MockWorld+execSysfsMockIO a w chips = snd <$> runSysfsMockIO a w chips++-- | Like 'SysfsGpioMock', but wraps 'IO' so that you can mix 'IO'+-- actions and GPIO actions in a mock GPIO environment.+type SysfsGpioMockIO = SysfsGpioT SysfsMockIO++-- | Run a 'SysfsGpioMockIO' computation with an initial mock world+-- and list of 'MockGpioChip's, and return a tuple containing the+-- computation's value and the final 'MockWorld'.+--+-- Before running the computation, the 'MockWorld' is populated with+-- the GPIO pins as specified by the list of 'MockGpioChip's. If any+-- of the chips' pin ranges overlap, a 'MockFSException' is thrown.+--+-- >>> import System.GPIO.Monad+-- >>> let mockChip = MockGpioChip "chip0" 0 (replicate 16 defaultMockPinState)+-- >>> fst <$> runSysfsGpioMockIO pins initialMockWorld [mockChip]+-- [Pin 0,Pin 1,Pin 2,Pin 3,Pin 4,Pin 5,Pin 6,Pin 7,Pin 8,Pin 9,Pin 10,Pin 11,Pin 12,Pin 13,Pin 14,Pin 15]+-- >>> fst <$> runSysfsGpioMockIO (openPin (Pin 32)) initialMockWorld [mockChip]+-- *** Exception: InvalidPin (Pin 32)+runSysfsGpioMockIO :: SysfsGpioMockIO a -> MockWorld -> [MockGpioChip] -> IO (a, MockWorld)+runSysfsGpioMockIO a = runSysfsMockIO (runSysfsGpioT a)++-- | Like 'runSysfsGpioMockIO', but returns only the computation's+-- value.+evalSysfsGpioMockIO :: SysfsGpioMockIO a -> MockWorld -> [MockGpioChip] -> IO a+evalSysfsGpioMockIO a = evalSysfsMockIO (runSysfsGpioT a)++-- | Like 'runSysfsGpioMockIO', but returns only the final+-- 'MockWorld'.+execSysfsGpioMockIO :: SysfsGpioMockIO a -> MockWorld -> [MockGpioChip] -> IO MockWorld+execSysfsGpioMockIO a = execSysfsMockIO (runSysfsGpioT a)++-- | Exceptions that can be thrown by mock @sysfs@ filesystem+-- operations.+--+-- Note that, as much as is reasonably possible, when an error occurs,+-- the mock filesystem implementation throws the same exception as+-- would occur in an actual @sysfs@ filesystem (i.e., 'IOError's).+-- However, in a few cases, there are exceptions that are specific to+-- the mock @sysfs@ implementation; in these cases, a+-- 'MockFSException' is thrown.+data MockFSException+ = GpioChipOverlap Pin+ -- ^ The user has defined defined at least two 'MockGpioChip's+ -- with the same pin number, which is an invalid condition+ | InternalError String+ -- ^ An internal error has occurred in the mock @sysfs@+ -- interpreter, something which should "never happen" and should+ -- be reported to the package maintainer.+ deriving (Show,Eq,Typeable)++instance Exception MockFSException where+ toException = gpioExceptionToException+ fromException = gpioExceptionFromException++makeFileSystem :: (Functor m, MonadThrow m) => [MockGpioChip] -> SysfsMockT m MockFSZipper+makeFileSystem chips =+ do mapM_ makeChip chips+ getZipper++makeChip :: (Functor m, MonadThrow m) => MockGpioChip -> SysfsMockT m ()+makeChip chip =+ let chipdir = sysfsPath </> ("gpiochip" ++ show (_base chip))+ in+ addPins (_base chip) (_initialPinStates chip) <$> getPins >>= \case+ Left e -> throwM e+ Right newPinState ->+ do putPins newPinState+ mkdir chipdir+ mkfile (chipdir </> "base") (Const [intToBS $ _base chip])+ mkfile (chipdir </> "ngpio") (Const [intToBS $ length (_initialPinStates chip)])+ mkfile (chipdir </> "label") (Const [C8.pack $ _label chip])++addPins :: Int -> [MockPinState] -> MockPins -> Either MockFSException MockPins+addPins base states pm = foldrM addPin pm (zip (map Pin [base..]) states)++addPin :: (Pin, MockPinState) -> MockPins -> Either MockFSException MockPins+addPin (pin, st) pm =+ let insertLookup = Map.insertLookupWithKey (\_ a _ -> a)+ in+ case insertLookup pin st pm of+ (Nothing, newPm) -> Right newPm+ (Just _, _) -> Left $ GpioChipOverlap pin++pushd :: (MonadThrow m) => FilePath -> SysfsMockT m a -> SysfsMockT m a+pushd path action =+ do z <- getZipper+ let restorePath = Internal.pathFromRoot z+ cd path >>= putZipper+ result <- action+ cd restorePath >>= putZipper+ return result++cd :: (MonadThrow m) => FilePath -> SysfsMockT m MockFSZipper+cd name =+ do fsz <- getZipper+ case Internal.cd name fsz of+ Left e -> throwM e+ Right newz -> return newz++mkdir :: (MonadThrow m) => FilePath -> SysfsMockT m ()+mkdir path =+ let (parentName, childName) = splitFileName path+ in+ do parent <- cd parentName+ either throwM putZipper (Internal.mkdir childName parent)++rmdir :: (MonadThrow m) => FilePath -> SysfsMockT m ()+rmdir path =+ let (parentName, childName) = splitFileName path+ in+ do parent <- cd parentName+ either throwM putZipper (Internal.rmdir childName parent)++mkfile :: (MonadThrow m) => FilePath -> FileType -> SysfsMockT m ()+mkfile path filetype =+ let (parentName, childName) = splitFileName path+ in+ do parent <- cd parentName+ either throwM putZipper (Internal.mkfile childName filetype False parent)++-- | Check whether the specified directory exists in the mock+-- filesystem.+doesDirectoryExist :: (Monad m) => FilePath -> SysfsMockT m Bool+doesDirectoryExist path =+ do cwz <- getZipper+ return $ either (const False) (const True) (Internal.cd path cwz)++-- | Check whether the specified file exists in the mock filesystem.+doesFileExist :: (Monad m) => FilePath -> SysfsMockT m Bool+doesFileExist path =+ let (dirPath, fileName) = splitFileName path+ in+ do cwz <- getZipper+ case Internal.cd dirPath cwz of+ Left _ -> return False+ Right z ->+ return $ isJust (findFile fileName (_cwd z))++-- | Get a directory listing for the specified directory in the mock+-- filesystem.+getDirectoryContents :: (Functor m, MonadThrow m) => FilePath -> SysfsMockT m [FilePath]+getDirectoryContents path =+ do parent <- _cwd <$> cd path+ return $ fmap dirName (subdirs parent) ++ fmap _fileName (files parent)++-- | Read the contents of the specified file in the mock filesystem.+readFile :: (Functor m, MonadThrow m) => FilePath -> SysfsMockT m ByteString+readFile path =+ fileAt path >>= \case+ Nothing ->+ do isDirectory <- doesDirectoryExist path+ if isDirectory+ then throwM $ mkIOError InappropriateType "Mock.readFile" Nothing (Just path)+ else throwM $ mkIOError NoSuchThing "Mock.readFile" Nothing (Just path)+ Just (Const contents) -> return $ C8.unlines contents+ Just (Value pin) -> pinValueToBS . logicalValue <$> pinState pin -- Use the logical "value" here!+ Just (ActiveLow pin) -> activeLowToBS . _activeLow <$> pinState pin+ Just (Direction pin) ->+ do visible <- _userVisibleDirection <$> pinState pin+ if visible+ then do direction <- _direction <$> pinState pin+ return $ pinDirectionToBS direction+ else throwM $ InternalError ("Mock pin " ++ show pin ++ " has no direction but direction attribute is exported")+ Just (Edge pin) ->+ _edge <$> pinState pin >>= \case+ Nothing -> throwM $ InternalError ("Mock pin " ++ show pin ++ " has no edge but edge attribute is exported")+ Just edge -> return $ sysfsEdgeToBS edge+ Just _ -> throwM $ mkIOError PermissionDenied "Mock.readFile" Nothing (Just path)++-- | Write the contents of the specified file in the mock filesystem.+writeFile :: (Functor m, MonadThrow m) => FilePath -> ByteString -> SysfsMockT m ()+writeFile path bs =+ -- NB: In some cases, more than one kind of error can occur (e.g.,+ -- when exporting a pin, the pin number may be invalid, or the pin+ -- may already be exported). We try to emulate what a real @sysfs@+ -- filesystem would do, so the order in which error conditions are+ -- checked matters here!+ fileAt path >>= \case+ Nothing ->+ do isDirectory <- doesDirectoryExist path+ if isDirectory+ then throwM $ mkIOError InappropriateType "Mock.writeFile" Nothing (Just path)+ else throwM $ mkIOError NoSuchThing "Mock.writeFile" Nothing (Just path)+ Just Export ->+ case bsToInt bs of+ Just n -> export (Pin n)+ Nothing -> throwM writeError+ Just Unexport ->+ case bsToInt bs of+ Just n -> unexport (Pin n)+ Nothing -> throwM writeError+ Just (ActiveLow pin) ->+ case bsToActiveLow bs of+ Just b -> putPinState pin (\s -> s {_activeLow = b})+ Nothing -> throwM writeError+ Just (Value pin) ->+ _direction <$> pinState pin >>= \case+ Out ->+ case bsToPinValue bs of+ Just v -> putPinState pin (setLogicalValue v)+ Nothing -> throwM writeError+ _ ->+ throwM permissionError+ Just (Edge pin) ->+ do ps <- pinState pin+ case (_edge ps, _direction ps) of+ (Nothing, _) -> throwM $ InternalError ("Mock pin " ++ show pin ++ " has no edge but edge attribute is exported")+ (_, Out) -> throwM $ mkIOError InvalidArgument "Mock.writeFile" Nothing (Just path)+ _ -> case bsToSysfsEdge bs of+ Just edge -> putPinState pin (\s -> s {_edge = Just edge})+ Nothing -> throwM writeError+ Just (Direction pin) ->+ -- NB: In Linux @sysfs@, writing a pin's @direction@ attribute+ -- with a "high" or "low" value sets the pin's /physical/ signal+ -- level to that state. In other words, the pin's @active_low@+ -- attribute is not considered when setting the pin's signal+ -- level via the @direction@ attribute. We faithfully mimic that+ -- behavior here.+ --+ -- NB: In Linux @sysfs@, if an input pin has been configured to+ -- generate interrupts (i.e., its @edge@ attribute is not+ -- @none@), changing its @direction@ attribute to @out@+ -- generates an I/O error. We emulate that behavior here.+ do ps <- pinState pin+ case (_userVisibleDirection ps, _edge ps, bsToPinDirection bs) of+ (False, _, _) -> throwM $ InternalError ("Mock pin " ++ show pin ++ " has no direction but direction attribute is exported")+ (True, _, Nothing) -> throwM writeError+ (True, Nothing, Just (dir, Nothing)) -> putPinState pin (\s -> s {_direction = dir})+ (True, Nothing, Just (dir, Just v)) -> putPinState pin (\s -> s {_direction = dir, _value = v})+ (True, Just None, Just (dir, Nothing)) -> putPinState pin (\s -> s {_direction = dir})+ (True, Just None, Just (dir, Just v)) -> putPinState pin (\s -> s {_direction = dir, _value = v})+ (True, _, Just (In, _)) -> putPinState pin (\s -> s {_direction = In})+ (True, _, Just (Out, _)) -> throwM $ mkIOError HardwareFault "Mock.writeFile" Nothing (Just path)+ Just _ -> throwM permissionError+ where+ writeError :: IOError+ writeError = mkIOError InvalidArgument "Mock.writeFile" Nothing (Just path)++ permissionError :: IOError+ permissionError = mkIOError PermissionDenied "Mock.writeFile" Nothing (Just path)++ export :: (Functor m, MonadThrow m) => Pin -> SysfsMockT m ()+ export pin =+ Map.lookup pin <$> getPins >>= \case+ Nothing -> throwM $ mkIOError InvalidArgument "Mock.writeFile" Nothing (Just path)+ Just s ->+ do let pindir = pinDirName pin+ -- Already exported?+ doesDirectoryExist pindir >>= \case+ True -> throwM $ mkIOError ResourceBusy "Mock.writeFile" Nothing (Just path)+ False ->+ do mkdir pindir+ mkfile (pinActiveLowFileName pin) (ActiveLow pin)+ mkfile (pinValueFileName pin) (Value pin)+ when (_userVisibleDirection s) $+ mkfile (pinDirectionFileName pin) (Direction pin)+ when (isJust $ _edge s) $+ mkfile (pinEdgeFileName pin) (Edge pin)++ unexport :: (MonadThrow m) => Pin -> SysfsMockT m ()+ unexport pin =+ do let pindir = pinDirName pin+ doesDirectoryExist pindir >>= \case+ True -> rmdir pindir -- recursive+ False -> throwM $ mkIOError InvalidArgument "Mock.writeFile" Nothing (Just path)++fileAt :: (Functor m, MonadThrow m) => FilePath -> SysfsMockT m (Maybe FileType)+fileAt path =+ let (dirPath, fileName) = splitFileName path+ in+ do parent <- _cwd <$> cd dirPath+ return $ findFile fileName parent++-- | For the mock filesystem, this action is equivalent to+-- 'writeFile'.+unlockedWriteFile :: (Functor m, MonadThrow m) => FilePath -> ByteString -> SysfsMockT m ()+unlockedWriteFile = writeFile++-- | Polling is not implemented for the mock filesystem, so this+-- action always returns the value @1@.+pollFile :: (Monad m) => FilePath -> Int -> SysfsMockT m CInt+pollFile _ _ = return 1++-- | The initial directory structure of a @sysfs@ GPIO filesystem.+sysfsRoot :: Directory+sysfsRoot =+ directory "/"+ []+ [directory "sys"+ []+ [directory "class"+ []+ [directory "gpio"+ [File "export" Export+ ,File "unexport" Unexport]+ []]]]++-- | The initial @sysfs@ filesystem zipper.+sysfsRootZipper :: MockFSZipper+sysfsRootZipper = MockFSZipper sysfsRoot []
+ src/System/GPIO/Linux/Sysfs/Mock/Internal.hs view
@@ -0,0 +1,238 @@+{-|+Module : System.GPIO.Linux.Sysfs.Mock.Internal+Description : Functions used by the mock MonadSysfs instance.+Copyright : (c) 2016, Drew Hess+License : BSD3+Maintainer : Drew Hess <src@drewhess.com>+Stability : experimental+Portability : non-portable++Types and functions to emulate a (pure) rudimentary Posix-style+filesystem.++This module was written for internal use only. Its interface may+change at any time. Documentation in this module is sparse, by design.++N.B.: This mock filesystem implementation was written with the+intention of doing only just enough to emulate the operations needed+by the 'System.GPIO.Linux.Sysfs.Monad.MonadSysfs' type class. Though+it may be possible to use this implementation for other purposes, it+has neither been designed nor tested for that. Use at your own risk+and please do not submit requests for addtional functionality.++-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Safe #-}++module System.GPIO.Linux.Sysfs.Mock.Internal+ ( -- * Mock filesystem types+ Name+ , File(..)+ , FileType(..)+ , DirNode(..)+ , Directory+ , directory+ , dirName+ , files+ , dirNode+ , subdirs+ , MockFSCrumb(..)+ , MockFSZipper(..)+ -- * Mock filesystem operations+ , cd+ , pathFromRoot+ , findFile+ , mkdir+ , mkfile+ , rmdir+ , rmfile+ ) where++import Prelude ()+import Prelude.Compat+import Data.ByteString (ByteString)+import Data.Foldable (foldlM)+import Data.List (find, unfoldr)+import Data.Maybe (isJust)+import Data.Tree (Tree(..))+import GHC.IO.Exception (IOErrorType(..))+import System.FilePath (isAbsolute, isValid, joinPath, splitDirectories)+import System.IO.Error (mkIOError)++import System.GPIO.Types (Pin)++type Name = String++data FileType+ = Const [ByteString]+ | Export+ | Unexport+ | Value Pin+ | Direction Pin+ | Edge Pin+ | ActiveLow Pin+ deriving (Show,Eq)++data File =+ File {_fileName :: !Name+ ,_fileType :: !FileType}+ deriving (Show,Eq)++data DirNode =+ DirNode {_dirNodeName :: !Name+ ,_files :: [File]}+ deriving (Show,Eq)++type Directory = Tree DirNode++-- Getters.++directory :: Name -> [File] -> [Directory] -> Directory+directory name fs = Node (DirNode name fs)++dirName :: Directory -> Name+dirName = _dirNodeName . dirNode++files :: Directory -> [File]+files = _files . dirNode++dirNode :: Directory -> DirNode+dirNode = rootLabel++subdirs :: Directory -> [Directory]+subdirs = subForest++data MockFSCrumb =+ MockFSCrumb {_node :: DirNode+ ,_pred :: [Directory]+ ,_succ :: [Directory]}+ deriving (Show,Eq)++-- | An opaque type representing the current state of the mock @sysfs@+-- filesystem. Because the constructor is not exported via the public+-- interface, you cannot create these directly, but you can manipulate+-- them using the exposed mock @sysfs@ operations and then pass those+-- 'MockFSZipper's around.+data MockFSZipper =+ MockFSZipper {_cwd :: Directory+ ,_crumbs :: [MockFSCrumb]}+ deriving (Show,Eq)++-- Logically equivalent to "cd .."+up :: MockFSZipper -> MockFSZipper+up (MockFSZipper dir (MockFSCrumb parent ls rs:bs)) =+ MockFSZipper (directory (_dirNodeName parent) (_files parent) (ls ++ [dir] ++ rs))+ bs+up (MockFSZipper dir []) = MockFSZipper dir [] -- cd /.. == /++root :: MockFSZipper -> MockFSZipper+root (MockFSZipper t []) = MockFSZipper t []+root z = root $ up z++pathFromRoot :: MockFSZipper -> FilePath+pathFromRoot zipper =+ joinPath $ "/" : reverse (unfoldr up' zipper)+ where+ up' :: MockFSZipper -> Maybe (Name, MockFSZipper)+ up' z@(MockFSZipper dir (_:_)) = Just (dirName dir, up z)+ up' (MockFSZipper _ []) = Nothing++findFile' :: Name -> Directory -> ([File], [File])+findFile' name dir = break (\file -> _fileName file == name) (files dir)++findFile :: Name -> Directory -> Maybe FileType+findFile name dir = _fileType <$> find (\file -> _fileName file == name) (files dir)++findDir' :: Name -> Directory -> ([Directory], [Directory])+findDir' name dir = break (\d -> dirName d == name) (subdirs dir)++findDir :: Name -> Directory -> Maybe Directory+findDir name dir = find (\d -> dirName d == name) (subdirs dir)++isValidName :: Name -> Bool+isValidName name = isValid name && notElem '/' name++cd :: FilePath -> MockFSZipper -> Either IOError MockFSZipper+cd p z =+ let (path, fs) =+ if isAbsolute p+ then (drop 1 p, root z)+ else (p, z)+ in foldlM cd' fs (splitDirectories path)+ where+ cd' :: MockFSZipper -> Name -> Either IOError MockFSZipper+ cd' zipper "." = Right zipper+ cd' zipper ".." = return $ up zipper+ cd' (MockFSZipper dir bs) name =+ case findDir' name dir of+ (ls,subdir:rs) ->+ Right $ MockFSZipper subdir (MockFSCrumb (dirNode dir) ls rs:bs)+ (_,[]) ->+ maybe (Left $ mkIOError NoSuchThing "Mock.Internal.cd" Nothing (Just p))+ (const $ Left $ mkIOError InappropriateType "Mock.Internal.cd" Nothing (Just p))+ (findFile name dir)++mkdir :: Name -> MockFSZipper -> Either IOError MockFSZipper+mkdir name (MockFSZipper cwd bs) =+ if isJust $ findFile name cwd+ then Left alreadyExists+ else+ case findDir' name cwd of+ (_, []) ->+ if isValidName name+ then+ let newDir = directory name [] []+ in+ Right $ MockFSZipper (directory (dirName cwd) (files cwd) (newDir:subdirs cwd))+ bs+ else Left $ mkIOError InvalidArgument "Mock.Internal.mkdir" Nothing (Just name)+ _ -> Left alreadyExists+ where+ alreadyExists :: IOError+ alreadyExists = mkIOError AlreadyExists "Mock.Internal.mkdir" Nothing (Just name)++mkfile :: Name -> FileType -> Bool -> MockFSZipper -> Either IOError MockFSZipper+mkfile name filetype clobber (MockFSZipper cwd bs) =+ case findFile' name cwd of+ (ls, _:rs) ->+ if clobber+ then mkfile' $ ls ++ rs+ else Left alreadyExists+ _ ->+ maybe (mkfile' $ files cwd)+ (const $ Left alreadyExists)+ (findDir name cwd)+ where+ mkfile' :: [File] -> Either IOError MockFSZipper+ mkfile' fs =+ if isValidName name+ then+ let newFile = File name filetype+ in+ Right $ MockFSZipper (directory (dirName cwd) (newFile:fs) (subdirs cwd))+ bs+ else Left $ mkIOError InvalidArgument "Mock.Internal.mkfile" Nothing (Just name)+ alreadyExists :: IOError+ alreadyExists = mkIOError AlreadyExists "Mock.Internal.mkfile" Nothing (Just name)++rmfile :: Name -> MockFSZipper -> Either IOError MockFSZipper+rmfile name (MockFSZipper cwd bs) =+ if isJust $ findDir name cwd+ then Left $ mkIOError InappropriateType "Mock.Internal.rmfile" Nothing (Just name)+ else+ case findFile' name cwd of+ (ls, _:rs) -> Right $ MockFSZipper (directory (dirName cwd) (ls ++ rs) (subdirs cwd))+ bs+ _ -> Left $ mkIOError NoSuchThing "Mock.Internal.rmdir" Nothing (Just name)++-- Note: recursive!+rmdir :: Name -> MockFSZipper -> Either IOError MockFSZipper+rmdir name (MockFSZipper cwd bs) =+ if isJust $ findFile name cwd+ then Left $ mkIOError InappropriateType "Mock.Internal.rmdir" Nothing (Just name)+ else+ case findDir' name cwd of+ (ls, _:rs) -> Right $ MockFSZipper (directory (dirName cwd) (files cwd) (ls ++ rs))+ bs+ _ -> Left $ mkIOError NoSuchThing "Mock.Internal.rmdir" Nothing (Just name)
+ src/System/GPIO/Linux/Sysfs/Monad.hs view
@@ -0,0 +1,787 @@+{-|+Module : System.GPIO.Linux.Sysfs.Monad+Description : Monads for Linux @sysfs@ GPIO operations+Copyright : (c) 2016, Drew Hess+License : BSD3+Maintainer : Drew Hess <src@drewhess.com>+Stability : experimental+Portability : non-portable++Monad type classes and instances for Linux @sysfs@ GPIO operations.++-}++{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Trustworthy #-}++module System.GPIO.Linux.Sysfs.Monad+ ( -- * MonadSysfs class+ MonadSysfs(..)+ -- * GPIO via @sysfs@+ , PinDescriptor(..)+ , SysfsGpioT(..)+ -- * Low-level @sysfs@ GPIO actions.+ --+ -- If you wish, you can bypass the portable GPIO computation+ -- layer provided by 'MonadGpio' and program directly to the+ -- Linux @sysfs@ GPIO interface in the 'MonadSysfs' monad.+ -- This requires only one level of abstraction (choosing a+ -- 'MonadSysfs' instance) rather than two (both a+ -- 'MonadSysfs' instance /and/ the 'SysfsGpioT' 'MonadGpio'+ -- instance).+ , sysfsIsPresent+ , availablePins+ , pinIsExported+ , exportPin+ , exportPinChecked+ , unexportPin+ , unexportPinChecked+ , pinHasDirection+ , readPinDirection+ , writePinDirection+ , writePinDirectionWithValue+ , readPinValue+ , pollPinValue+ , pollPinValueTimeout+ , writePinValue+ , pinHasEdge+ , readPinEdge+ , writePinEdge+ , readPinActiveLow+ , writePinActiveLow+ ) where++import Prelude ()+import Prelude.Compat hiding (readFile, writeFile)+import Control.Applicative (Alternative)+import Control.Monad (MonadPlus, filterM, void)+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, catchIOError, throwM)+import Control.Monad.Catch.Pure (CatchT)+import Control.Monad.Cont (MonadCont, ContT)+import Control.Monad.Except (MonadError, ExceptT)+import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Reader (MonadReader, ReaderT)+import Control.Monad.RWS (MonadRWS)+import Control.Monad.State (MonadState)+import Control.Monad.Trans.Class (MonadTrans, lift)+import Control.Monad.Trans.Identity (IdentityT)+import Control.Monad.Trans.List (ListT)+import Control.Monad.Trans.Maybe (MaybeT)+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST)+import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST)+import qualified Control.Monad.Trans.State.Lazy as LazyState (StateT)+import qualified Control.Monad.Trans.State.Strict as StrictState (StateT)+import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter (WriterT)+import qualified Control.Monad.Trans.Writer.Strict as StrictWriter (WriterT)+import Control.Monad.Writer (MonadWriter)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as C8 (readInt, unpack)+import Data.List (isPrefixOf, sort)+import qualified Data.Set as Set (empty, fromList)+import Foreign.C.Types (CInt(..))+import qualified GHC.IO.Exception as IO (IOErrorType(..))+import System.FilePath ((</>), takeFileName)+import System.IO.Error+ (ioeGetErrorType, isAlreadyInUseError, isDoesNotExistError,+ isPermissionError)++import System.GPIO.Linux.Sysfs.Types (SysfsEdge(..), SysfsException(..), toPinInterruptMode, toSysfsEdge)+import System.GPIO.Linux.Sysfs.Util+ (intToBS, pinActiveLowFileName, pinDirectionFileName,+ pinEdgeFileName, pinValueFileName, pinDirName, activeLowToBS,+ pinDirectionToBS, pinDirectionValueToBS, sysfsEdgeToBS,+ pinValueToBS, sysfsPath, exportFileName, unexportFileName)+import System.GPIO.Monad (MonadGpio(..), withPin)+import System.GPIO.Types+ (Pin(..), PinActiveLevel(..), PinCapabilities(..),+ PinDirection(..), PinInputMode(..), PinOutputMode(..),+ PinValue(..), invertValue)++-- | A type class for monads which implement (or mock) low-level Linux+-- @sysfs@ GPIO operations.+class (Monad m) => MonadSysfs m where+ -- | Equivalent to 'System.Directory.doesDirectoryExist'.+ doesDirectoryExist :: FilePath -> m Bool+ -- | Equivalent to 'System.Directory.doesFileExist'.+ doesFileExist :: FilePath -> m Bool+ -- | Equivalent to 'System.Directory.getDirectoryContents'.+ getDirectoryContents :: FilePath -> m [FilePath]+ -- | Equivalent to 'Data.ByteString.readFile'.+ readFile :: FilePath -> m ByteString+ -- | Equivalent to 'Data.ByteString.writeFile'.+ writeFile :: FilePath -> ByteString -> m ()+ -- | @sysfs@ control files which are global shared resources may be+ -- written simultaneously by multiple threads. This is fine --+ -- @sysfs@ can handle this -- but Haskell's+ -- 'Data.ByteString.writeFile' cannot, as it locks the file and+ -- prevents multiple writers. We don't want this behavior, so we use+ -- low-level operations to get around it.+ unlockedWriteFile :: FilePath -> ByteString -> m ()+ -- | Poll a @sysfs@ file for reading, as in POSIX.1-2001 @poll(2)@.+ --+ -- Note that the implementation of this action is only guaranteed to+ -- work for @sysfs@ files, which have a peculiar way of signaling+ -- readiness for reads. Do not use it for any other purpose.+ pollFile :: FilePath -> Int -> m CInt++instance (MonadSysfs m) => MonadSysfs (IdentityT m) where+ doesDirectoryExist = lift . doesDirectoryExist+ doesFileExist = lift . doesFileExist+ getDirectoryContents = lift . getDirectoryContents+ readFile = lift . readFile+ writeFile fn bs = lift $ writeFile fn bs+ unlockedWriteFile fn bs = lift $ unlockedWriteFile fn bs+ pollFile fn timeout = lift $ pollFile fn timeout++instance (MonadSysfs m) => MonadSysfs (ContT r m) where+ doesDirectoryExist = lift . doesDirectoryExist+ doesFileExist = lift . doesFileExist+ getDirectoryContents = lift . getDirectoryContents+ readFile = lift . readFile+ writeFile fn bs = lift $ writeFile fn bs+ unlockedWriteFile fn bs = lift $ unlockedWriteFile fn bs+ pollFile fn timeout = lift $ pollFile fn timeout++instance (MonadSysfs m) => MonadSysfs (CatchT m) where+ doesDirectoryExist = lift . doesDirectoryExist+ doesFileExist = lift . doesFileExist+ getDirectoryContents = lift . getDirectoryContents+ readFile = lift . readFile+ writeFile fn bs = lift $ writeFile fn bs+ unlockedWriteFile fn bs = lift $ unlockedWriteFile fn bs+ pollFile fn timeout = lift $ pollFile fn timeout++instance (MonadSysfs m) => MonadSysfs (ExceptT e m) where+ doesDirectoryExist = lift . doesDirectoryExist+ doesFileExist = lift . doesFileExist+ getDirectoryContents = lift . getDirectoryContents+ readFile = lift . readFile+ writeFile fn bs = lift $ writeFile fn bs+ unlockedWriteFile fn bs = lift $ unlockedWriteFile fn bs+ pollFile fn timeout = lift $ pollFile fn timeout++instance (MonadSysfs m) => MonadSysfs (ListT m) where+ doesDirectoryExist = lift . doesDirectoryExist+ doesFileExist = lift . doesFileExist+ getDirectoryContents = lift . getDirectoryContents+ readFile = lift . readFile+ writeFile fn bs = lift $ writeFile fn bs+ unlockedWriteFile fn bs = lift $ unlockedWriteFile fn bs+ pollFile fn timeout = lift $ pollFile fn timeout++instance (MonadSysfs m) => MonadSysfs (MaybeT m) where+ doesDirectoryExist = lift . doesDirectoryExist+ doesFileExist = lift . doesFileExist+ getDirectoryContents = lift . getDirectoryContents+ readFile = lift . readFile+ writeFile fn bs = lift $ writeFile fn bs+ unlockedWriteFile fn bs = lift $ unlockedWriteFile fn bs+ pollFile fn timeout = lift $ pollFile fn timeout++instance (MonadSysfs m) => MonadSysfs (ReaderT r m) where+ doesDirectoryExist = lift . doesDirectoryExist+ doesFileExist = lift . doesFileExist+ getDirectoryContents = lift . getDirectoryContents+ readFile = lift . readFile+ writeFile fn bs = lift $ writeFile fn bs+ unlockedWriteFile fn bs = lift $ unlockedWriteFile fn bs+ pollFile fn timeout = lift $ pollFile fn timeout++instance (MonadSysfs m, Monoid w) => MonadSysfs (LazyRWS.RWST r w s m) where+ doesDirectoryExist = lift . doesDirectoryExist+ doesFileExist = lift . doesFileExist+ getDirectoryContents = lift . getDirectoryContents+ readFile = lift . readFile+ writeFile fn bs = lift $ writeFile fn bs+ unlockedWriteFile fn bs = lift $ unlockedWriteFile fn bs+ pollFile fn timeout = lift $ pollFile fn timeout++instance (MonadSysfs m, Monoid w) => MonadSysfs (StrictRWS.RWST r w s m) where+ doesDirectoryExist = lift . doesDirectoryExist+ doesFileExist = lift . doesFileExist+ getDirectoryContents = lift . getDirectoryContents+ readFile = lift . readFile+ writeFile fn bs = lift $ writeFile fn bs+ unlockedWriteFile fn bs = lift $ unlockedWriteFile fn bs+ pollFile fn timeout = lift $ pollFile fn timeout++instance (MonadSysfs m) => MonadSysfs (LazyState.StateT s m) where+ doesDirectoryExist = lift . doesDirectoryExist+ doesFileExist = lift . doesFileExist+ getDirectoryContents = lift . getDirectoryContents+ readFile = lift . readFile+ writeFile fn bs = lift $ writeFile fn bs+ unlockedWriteFile fn bs = lift $ unlockedWriteFile fn bs+ pollFile fn timeout = lift $ pollFile fn timeout++instance (MonadSysfs m) => MonadSysfs (StrictState.StateT s m) where+ doesDirectoryExist = lift . doesDirectoryExist+ doesFileExist = lift . doesFileExist+ getDirectoryContents = lift . getDirectoryContents+ readFile = lift . readFile+ writeFile fn bs = lift $ writeFile fn bs+ unlockedWriteFile fn bs = lift $ unlockedWriteFile fn bs+ pollFile fn timeout = lift $ pollFile fn timeout++instance (MonadSysfs m, Monoid w) => MonadSysfs (LazyWriter.WriterT w m) where+ doesDirectoryExist = lift . doesDirectoryExist+ doesFileExist = lift . doesFileExist+ getDirectoryContents = lift . getDirectoryContents+ readFile = lift . readFile+ writeFile fn bs = lift $ writeFile fn bs+ unlockedWriteFile fn bs = lift $ unlockedWriteFile fn bs+ pollFile fn timeout = lift $ pollFile fn timeout++instance (MonadSysfs m, Monoid w) => MonadSysfs (StrictWriter.WriterT w m) where+ doesDirectoryExist = lift . doesDirectoryExist+ doesFileExist = lift . doesFileExist+ getDirectoryContents = lift . getDirectoryContents+ readFile = lift . readFile+ writeFile fn bs = lift $ writeFile fn bs+ unlockedWriteFile fn bs = lift $ unlockedWriteFile fn bs+ pollFile fn timeout = lift $ pollFile fn timeout++-- | The @sysfs@ pin handle type. Currently it's just a newtype+-- wrapper around a 'Pin'. The constructor is exported for+-- convenience, but note that the implementation may change in future+-- versions of the package.+newtype PinDescriptor =+ PinDescriptor {_pin :: Pin}+ deriving (Show,Eq,Ord)++-- | An instance of 'MonadGpio' which translates actions in that monad+-- to operations on Linux's native @sysfs@ GPIO interface.+newtype SysfsGpioT m a =+ SysfsGpioT {runSysfsGpioT :: m a}+ deriving (Functor,Alternative,Applicative,Monad,MonadFix,MonadPlus,MonadThrow,MonadCatch,MonadMask,MonadCont,MonadIO,MonadReader r,MonadError e,MonadWriter w,MonadState s,MonadRWS r w s)++instance MonadTrans SysfsGpioT where+ lift = SysfsGpioT++instance (Functor m, MonadCatch m, MonadMask m, MonadThrow m, MonadSysfs m) => MonadGpio PinDescriptor (SysfsGpioT m) where+ pins =+ lift sysfsIsPresent >>= \case+ False -> return []+ True -> lift availablePins++ -- The @sysfs@ GPIO interface is particularly information-poor. It+ -- is not currently possible, in a hardware-independent way, to+ -- determine which particular input and output modes a pin supports,+ -- for example.+ --+ -- For input pins, therefore, we can only claim 'InputDefault'+ -- support. However, for output pins, it's possible to emulate both+ -- 'OutputOpenDrain' and 'OutputOpenSource' modes by switching the+ -- pin into input mode for 'High' (in the case of 'OutputOpenDrain')+ -- or 'Low' ('OutputOpenSource') values. We do not currently support+ -- this, but it's a planned feature.+ --+ -- If a pin has no @direction@ attribute, it means there is no+ -- hardware-independent way to determine its hard-wired direction+ -- via @sysfs@. That means there's no practical way to use it with+ -- the cross-platform DSL, so in this case we simply report the pin+ -- as having no capabilities.+ pinCapabilities p =+ lift sysfsIsPresent >>= \case+ False -> throwM SysfsNotPresent+ True ->+ withPin p $ \_ ->+ do hasDir <- lift $ pinHasDirection p+ hasEdge <- lift $ pinHasEdge p+ if hasDir+ then return $ PinCapabilities (Set.fromList [InputDefault])+ (Set.fromList [OutputDefault])+ hasEdge+ else return $ PinCapabilities Set.empty Set.empty False++ openPin p =+ lift sysfsIsPresent >>= \case+ False -> throwM SysfsNotPresent+ True ->+ do lift $ exportPin p+ return $ PinDescriptor p++ closePin (PinDescriptor p) = lift $ unexportPin p++ getPinDirection (PinDescriptor p) =+ lift $ readPinDirection p++ getPinInputMode (PinDescriptor p) =+ do dir <- lift $ readPinDirection p+ if dir == In+ then return InputDefault+ else throwM $ InvalidOperation p++ setPinInputMode (PinDescriptor p) mode =+ if mode == InputDefault+ then lift $ writePinDirection p In+ else throwM $ UnsupportedInputMode mode p++ getPinOutputMode (PinDescriptor p) =+ do dir <- lift $ readPinDirection p+ if dir == Out+ then return OutputDefault+ else throwM $ InvalidOperation p++ setPinOutputMode (PinDescriptor p) mode v =+ if mode == OutputDefault+ then lift $ writePinDirectionWithValue p v+ else throwM $ UnsupportedOutputMode mode p++ readPin (PinDescriptor p) = lift $ readPinValue p++ pollPin (PinDescriptor p) = lift $ pollPinValue p++ pollPinTimeout (PinDescriptor p) timeout =+ lift $ pollPinValueTimeout p timeout++ writePin (PinDescriptor p) v =+ lift $ writePinValue p v++ togglePin h =+ do val <- readPin h+ let newVal = invertValue val+ void $ writePin h newVal+ return newVal++ getPinInterruptMode (PinDescriptor p) =+ do edge <- lift $ readPinEdge p+ return $ toPinInterruptMode edge++ setPinInterruptMode (PinDescriptor p) mode =+ lift $ writePinEdge p $ toSysfsEdge mode++ getPinActiveLevel (PinDescriptor p) =+ do activeLow <- lift $ readPinActiveLow p+ return $ activeLowToActiveLevel activeLow++ setPinActiveLevel (PinDescriptor p) l =+ lift $ writePinActiveLow p $ activeLevelToActiveLow l++ togglePinActiveLevel (PinDescriptor p) =+ do toggled <- not <$> lift (readPinActiveLow p)+ lift $ writePinActiveLow p toggled+ return $ activeLowToActiveLevel toggled++activeLevelToActiveLow :: PinActiveLevel -> Bool+activeLevelToActiveLow ActiveLow = True+activeLevelToActiveLow ActiveHigh = False++activeLowToActiveLevel :: Bool -> PinActiveLevel+activeLowToActiveLevel False = ActiveHigh+activeLowToActiveLevel True = ActiveLow++-- | Test whether the @sysfs@ GPIO filesystem is available.+sysfsIsPresent :: (MonadSysfs m) => m Bool+sysfsIsPresent = doesDirectoryExist sysfsPath++-- | Test whether the pin is already exported.+pinIsExported :: (MonadSysfs m) => Pin -> m Bool+pinIsExported = doesDirectoryExist . pinDirName++-- | Export the given pin.+--+-- Note that, if the pin is already exported, this is not an error; in+-- this situation, the pin remains exported and its state unchanged.+exportPin :: (MonadSysfs m, MonadCatch m) => Pin -> m ()+exportPin pin@(Pin n) =+ catchIOError+ (unlockedWriteFile exportFileName (intToBS n))+ mapIOError+ where+ mapIOError :: (MonadThrow m) => IOError -> m ()+ mapIOError e+ | isAlreadyInUseError e = return ()+ | isInvalidArgumentError e = throwM $ InvalidPin pin+ | isPermissionError e = throwM $ PermissionDenied pin+ | otherwise = throwM e++-- | Export the given pin.+--+-- Note that, unlike 'exportPin', it's an error to call this action to+-- export a pin that's already been exported. This is the standard+-- Linux @sysfs@ GPIO behavior.+exportPinChecked :: (MonadCatch m, MonadSysfs m) => Pin -> m ()+exportPinChecked pin@(Pin n) =+ catchIOError+ (unlockedWriteFile exportFileName (intToBS n))+ mapIOError+ where+ mapIOError :: (MonadThrow m) => IOError -> m ()+ mapIOError e+ | isAlreadyInUseError e = throwM $ AlreadyExported pin+ | isInvalidArgumentError e = throwM $ InvalidPin pin+ | isPermissionError e = throwM $ PermissionDenied pin+ | otherwise = throwM e++-- | Unexport the given pin.+--+-- Note that, if the pin is already unexported or cannot be+-- unexported, this is not an error. In this situation, the pin+-- remains exported and its state unchanged.+unexportPin :: (MonadSysfs m, MonadCatch m) => Pin -> m ()+unexportPin pin@(Pin n) =+ catchIOError+ (unlockedWriteFile unexportFileName (intToBS n))+ mapIOError+ where+ mapIOError :: (MonadThrow m) => IOError -> m ()+ mapIOError e+ | isInvalidArgumentError e = return ()+ | isPermissionError e = throwM $ PermissionDenied pin+ | otherwise = throwM e++-- | Unexport the given pin.+--+-- Note that, unlike 'unexportPin', it is an error to call this action+-- if the pin is not currently exported. This is the standard Linux+-- @sysfs@ GPIO behavior.+unexportPinChecked :: (MonadSysfs m, MonadCatch m) => Pin -> m ()+unexportPinChecked pin@(Pin n) =+ catchIOError+ (unlockedWriteFile unexportFileName (intToBS n))+ mapIOError+ where+ mapIOError :: (MonadThrow m) => IOError -> m ()+ mapIOError e+ | isInvalidArgumentError e = throwM $ NotExported pin+ | isPermissionError e = throwM $ PermissionDenied pin+ | otherwise = throwM e++-- | Test whether the pin's direction can be set via the @sysfs@ GPIO+-- filesystem. (Some pins have a hard-wired direction, in which case+-- their direction must be determined by some other mechanism, as the+-- @direction@ attribute does not exist for such pins.)+pinHasDirection :: (MonadSysfs m, MonadThrow m) => Pin -> m Bool+pinHasDirection p =+ do exported <- pinIsExported p+ if exported+ then doesFileExist (pinDirectionFileName p)+ else throwM $ NotExported p++-- | Read the pin's direction.+--+-- It is an error to call this action if the pin has no @direction@+-- attribute.+readPinDirection :: (MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> m PinDirection+readPinDirection p =+ catchIOError+ (readFile (pinDirectionFileName p) >>= \case+ "in\n" -> return In+ "out\n" -> return Out+ x -> throwM $ UnexpectedDirection p (C8.unpack x))+ mapIOError+ where+ mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m PinDirection+ mapIOError e+ | isDoesNotExistError e =+ do exported <- pinIsExported p+ if exported+ then throwM $ NoDirectionAttribute p+ else throwM $ NotExported p+ | isPermissionError e = throwM $ PermissionDenied p+ | otherwise = throwM e++-- | Set the pin's direction.+--+-- It is an error to call this action if the pin has no @direction@+-- attribute.+--+-- Note that, in Linux @sysfs@ GPIO, changing a pin's direction to+-- @out@ will also set its /physical/ signal level to @low@.+--+-- NB: in Linux @sysfs@, if an input pin is cofigured for edge- or+-- level-triggered reads, it's an error to set its direction to @out@.+-- However, this action will handle that case gracefully by setting+-- the pin's @edge@ attribute to @none@ before setting the pin's+-- direction to @out@.+writePinDirection :: (MonadSysfs m, MonadCatch m) => Pin -> PinDirection -> m ()+writePinDirection p In =+ writeDirection p (pinDirectionToBS In)+writePinDirection p Out =+ do resetEdge p+ writeDirection p (pinDirectionToBS Out)++-- | Pins whose direction can be set may be configured for output by+-- writing a 'PinValue' to their @direction@ attribute, such that the+-- given value will be driven on the pin as soon as it's configured+-- for output. This enables glitch-free output configuration, assuming+-- the pin is currently configured for input, or some kind of+-- tri-stated or floating high-impedance mode.+--+-- It is an error to call this action if the pin has no @direction@+-- attribute.+--+-- NB: for some unfathomable reason, writing @high@ or @low@ to a+-- pin's @direction@ attribute sets its /physical/ signal level; i.e.,+-- it ignores the value of the pin's @active_low@ attribute. Contrast+-- this behavior with the behavior of writing to the pin's @value@+-- attribute, which respects the value of the pin's @active_low@+-- attribute and sets the pin's /logical/ signal level.+--+-- Rather than slavishly following the Linux @sysfs@ GPIO spec, we+-- choose to be consistent by taking into account the pin's active+-- level when writing the @direction@ attribute. In other words, the+-- 'PinValue' argument to this action is the /logical/ signal level+-- that will be set on the pin. If you're using this action to program+-- directly to the Linux @sysfs@ GPIO interface and expecting things+-- to behave as they do with raw @sysfs@ GPIO operations, keep this in+-- mind!+writePinDirectionWithValue :: (MonadSysfs m, MonadCatch m) => Pin -> PinValue -> m ()+writePinDirectionWithValue p v =+ do activeLow <- readPinActiveLow p+ let f = if activeLow then invertValue else id+ resetEdge p+ writeDirection p (pinDirectionValueToBS $ f v)++resetEdge :: (MonadSysfs m, MonadCatch m) => Pin -> m ()+resetEdge p =+ maybeReadPinEdge >>= \case+ Nothing -> return ()+ Just None -> return ()+ _ -> writePinEdge p None+ where+ maybeReadPinEdge :: (MonadSysfs m, MonadCatch m) => m (Maybe SysfsEdge)+ maybeReadPinEdge =+ pinHasEdge p >>= \case+ False -> return Nothing+ True ->+ do edge <- readPinEdge p+ return $ Just edge+++writeDirection :: (MonadSysfs m, MonadCatch m) => Pin -> ByteString -> m ()+writeDirection p bs =+ catchIOError+ (writeFile (pinDirectionFileName p) bs)+ mapIOError+ where+ mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m ()+ mapIOError e+ | isDoesNotExistError e =+ do exported <- pinIsExported p+ if exported+ then throwM $ NoDirectionAttribute p+ else throwM $ NotExported p+ | isPermissionError e = throwM $ PermissionDenied p+ | otherwise = throwM e+-- | Read the pin's signal level.+--+-- Note that this action never blocks, regardless of the pin's @edge@+-- attribute setting.+readPinValue :: (MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> m PinValue+readPinValue p =+ catchIOError+ (readFile (pinValueFileName p) >>= \case+ "0\n" -> return Low+ "1\n" -> return High+ x -> throwM $ UnexpectedValue p (C8.unpack x))+ mapIOError+ where+ mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m PinValue+ mapIOError e+ | isDoesNotExistError e = throwM $ NotExported p+ | isPermissionError e = throwM $ PermissionDenied p+ | otherwise = throwM e++-- | A blocking version of 'readPinValue'. The current thread will+-- block until an event occurs on the pin as specified by the pin's+-- current @edge@ attribute setting.+--+-- If the pin has no @edge@ attribute, then this action's behavior is+-- undefined. (Most likely, it will block indefinitely.)+pollPinValue :: (Functor m, MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> m PinValue+pollPinValue p =+ pollPinValueTimeout p (-1) >>= \case+ Just v -> return v+ -- 'Nothing' can only occur when the poll has timed out, but the+ -- (-1) timeout value above means the poll must either wait+ -- forever or fail; so this indicates a major problem.+ Nothing -> throwM $+ InternalError "pollPinValue timed out, and it should not have. Please file a bug at https://github.com/dhess/gpio"++-- | Same as 'pollPinValue', except that a timeout value,+-- specified in microseconds, is provided. If no event occurs before+-- the timeout expires, this action returns 'Nothing'; otherwise, it+-- returns the pin's value wrapped in a 'Just'.+--+-- If the timeout value is negative, this action behaves just like+-- 'pollPinValue'.+--+-- When specifying a timeout value, be careful not to exceed+-- 'maxBound'.+--+-- If the pin has no @edge@ attribute, then this action's behavior is+-- undefined. (Most likely, it will time out after the specified delay+-- and return 'Nothing'.)+--+-- NB: the curent implementation of this action limits the timeout+-- precision to 1 millisecond, rather than 1 microsecond as the+-- timeout parameter implies.+pollPinValueTimeout :: (Functor m, MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> Int -> m (Maybe PinValue)+pollPinValueTimeout p timeout =+ catchIOError+ (do pollResult <- pollFile (pinValueFileName p) timeout+ if pollResult > 0+ then Just <$> readPinValue p+ else return Nothing)+ mapIOError+ where+ mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m (Maybe PinValue)+ mapIOError e+ | isDoesNotExistError e = throwM $ NotExported p+ | isPermissionError e = throwM $ PermissionDenied p+ | otherwise = throwM e++-- | Set the pin's signal level.+--+-- It is an error to call this action if the pin is configured as an+-- input pin.+writePinValue :: (MonadSysfs m, MonadCatch m) => Pin -> PinValue -> m ()+writePinValue p v =+ catchIOError+ (writeFile (pinValueFileName p) (pinValueToBS v))+ mapIOError+ where+ mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m ()+ mapIOError e+ | isDoesNotExistError e = throwM $ NotExported p+ | isPermissionError e = throwM $ PermissionDenied p+ | otherwise = throwM e++-- | Test whether the pin has an @edge@ attribute, i.e., whether it+-- can be configured for edge- or level-triggered interrupts.+pinHasEdge :: (MonadSysfs m, MonadThrow m) => Pin -> m Bool+pinHasEdge p =+ do exported <- pinIsExported p+ if exported+ then doesFileExist (pinEdgeFileName p)+ else throwM $ NotExported p++-- | Read the pin's @edge@ attribute.+--+-- It is an error to call this action when the pin has no @edge@+-- attribute.+readPinEdge :: (MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> m SysfsEdge+readPinEdge p =+ catchIOError+ (readFile (pinEdgeFileName p) >>= \case+ "none\n" -> return None+ "rising\n" -> return Rising+ "falling\n" -> return Falling+ "both\n" -> return Both+ x -> throwM $ UnexpectedEdge p (C8.unpack x))+ mapIOError+ where+ mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m SysfsEdge+ mapIOError e+ | isDoesNotExistError e =+ do exported <- pinIsExported p+ if exported+ then throwM $ NoEdgeAttribute p+ else throwM $ NotExported p+ | isPermissionError e = throwM $ PermissionDenied p+ | otherwise = throwM e++-- | Write the pin's @edge@ attribute.+--+-- It is an error to call this action when the pin has no @edge@+-- attribute, or when the pin is configured for output.+writePinEdge :: (MonadSysfs m, MonadCatch m) => Pin -> SysfsEdge -> m ()+writePinEdge p v =+ catchIOError+ (writeFile (pinEdgeFileName p) (sysfsEdgeToBS v))+ mapIOError+ where+ mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m ()+ mapIOError e+ | isDoesNotExistError e =+ do exported <- pinIsExported p+ if exported+ then throwM $ NoEdgeAttribute p+ else throwM $ NotExported p+ | isInvalidArgumentError e = throwM $ InvalidOperation p+ | isPermissionError e = throwM $ PermissionDenied p+ | otherwise = throwM e++-- | Read the pin's @active_low@ attribute.+readPinActiveLow :: (MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> m Bool+readPinActiveLow p =+ catchIOError+ (readFile (pinActiveLowFileName p) >>= \case+ "0\n" -> return False+ "1\n" -> return True+ x -> throwM $ UnexpectedActiveLow p (C8.unpack x))+ mapIOError+ where+ mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m Bool+ mapIOError e+ | isDoesNotExistError e = throwM $ NotExported p+ | isPermissionError e = throwM $ PermissionDenied p+ | otherwise = throwM e++-- | Write the pin's @active_low@ attribute.+writePinActiveLow :: (MonadSysfs m, MonadCatch m) => Pin -> Bool -> m ()+writePinActiveLow p v =+ catchIOError+ (writeFile (pinActiveLowFileName p) (activeLowToBS v))+ mapIOError+ where+ mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m ()+ mapIOError e+ | isDoesNotExistError e = throwM $ NotExported p+ | isPermissionError e = throwM $ PermissionDenied p+ | otherwise = throwM e++-- | Return a list of all pins that are exposed via the @sysfs@ GPIO+-- filesystem. Note that the returned list may omit some pins that+-- are available on the host but which, for various reasons, are not+-- exposed via the @sysfs@ GPIO filesystem.+availablePins :: (MonadSysfs m, MonadThrow m, MonadCatch m) => m [Pin]+availablePins =+ catchIOError+ (do sysfsEntries <- getDirectoryContents sysfsPath+ let sysfsContents = fmap (sysfsPath </>) sysfsEntries+ sysfsDirectories <- filterM doesDirectoryExist sysfsContents+ let chipDirs = filter (isPrefixOf "gpiochip" . takeFileName) sysfsDirectories+ gpioPins <- mapM pinRange chipDirs+ return $ sort $ concat gpioPins)+ mapIOError+ where+ mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m [Pin]+ mapIOError e+ | isDoesNotExistError e = throwM SysfsError+ | isPermissionError e = throwM SysfsPermissionDenied+ | otherwise = throwM e++-- Helper actions that aren't exported.+--++readIntFromFile :: (MonadSysfs m, MonadThrow m) => FilePath -> m Int+readIntFromFile f =+ do contents <- readFile f+ case C8.readInt contents of+ Just (n, _) -> return n+ Nothing -> throwM $ UnexpectedContents f (C8.unpack contents)++pinRange :: (MonadSysfs m, MonadThrow m) => FilePath -> m [Pin]+pinRange chipDir =+ do base <- readIntFromFile (chipDir </> "base")+ ngpio <- readIntFromFile (chipDir </> "ngpio")+ if base >= 0 && ngpio > 0+ then return $ fmap Pin [base .. (base + ngpio - 1)]+ else return []++-- IOErrorType predicates for the extended GHC.IO.Exception types+-- which we use.++isInvalidArgumentErrorType :: IO.IOErrorType -> Bool+isInvalidArgumentErrorType IO.InvalidArgument = True+isInvalidArgumentErrorType _ = False++isInvalidArgumentError :: IOError -> Bool+isInvalidArgumentError = isInvalidArgumentErrorType . ioeGetErrorType
+ src/System/GPIO/Linux/Sysfs/Types.hs view
@@ -0,0 +1,158 @@+{-|+Module : System.GPIO.Linux.Sysfs.Types+Description : Types for Linux @sysfs@ GPIO+Copyright : (c) 2016, Drew Hess+License : BSD3+Maintainer : Drew Hess <src@drewhess.com>+Stability : experimental+Portability : non-portable++Types used by the various Linux @sysfs@ GPIO implementations.++-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE Safe #-}++module System.GPIO.Linux.Sysfs.Types+ ( -- * @sysfs@-specific types+ SysfsEdge(..)+ , toPinInterruptMode+ , toSysfsEdge+ -- * Exceptions+ , SysfsException(..)+ ) where++import Control.Monad.Catch (Exception(..))+import Data.Data+import GHC.Generics+import Test.QuickCheck (Arbitrary(..), arbitraryBoundedEnum, genericShrink)++import System.GPIO.Types+ (Pin, PinInputMode, PinOutputMode, PinInterruptMode(..),+ gpioExceptionToException, gpioExceptionFromException)++-- | Linux GPIO pins that can be configured to generate inputs have an+-- @edge@ attribute in the @sysfs@ GPIO filesystem. This type+-- represents the values that the @edge@ attribute can take.+--+-- Note that in Linux @sysfs@ GPIO, the signal edge referred to by the+-- @edge@ attribute refers to the signal's /logical/ value; i.e., it+-- takes into account the value of the pin's @active_low@ attribute.+--+-- This type is isomorphic to the 'PinInterruptMode' type. See+-- 'toPinInterruptMode' and 'toSysfsEdge'.+data SysfsEdge+ = None+ -- ^ Interrupts disabled+ | Rising+ -- ^ Interrupt on the (logical) signal's rising edge+ | Falling+ -- ^ Interrupt on the (logical) signal's falling edge+ | Both+ -- ^ Interrupt on any change to the signal level+ deriving (Bounded,Enum,Eq,Data,Ord,Read,Show,Generic,Typeable)++instance Arbitrary SysfsEdge where+ arbitrary = arbitraryBoundedEnum+ shrink = genericShrink++-- | Convert a 'SysfsEdge' value to its equivalent 'PinInterruptMode'+-- value.+--+-- >>> toPinInterruptMode None+-- Disabled+-- >>> toPinInterruptMode Rising+-- RisingEdge+-- >>> toPinInterruptMode Falling+-- FallingEdge+-- >>> toPinInterruptMode Both+-- Level+toPinInterruptMode :: SysfsEdge -> PinInterruptMode+toPinInterruptMode None = Disabled+toPinInterruptMode Rising = RisingEdge+toPinInterruptMode Falling = FallingEdge+toPinInterruptMode Both = Level++-- | Convert a 'PinInterruptMode' value to its equivalent 'SysfsEdge'+-- value.+--+-- >>> toSysfsEdge Disabled+-- None+-- >>> toSysfsEdge RisingEdge+-- Rising+-- >>> toSysfsEdge FallingEdge+-- Falling+-- >>> toSysfsEdge Level+-- Both+toSysfsEdge :: PinInterruptMode -> SysfsEdge+toSysfsEdge Disabled = None+toSysfsEdge RisingEdge = Rising+toSysfsEdge FallingEdge = Falling+toSysfsEdge Level = Both++-- | Exceptions that can be thrown by @sysfs@ computations (in+-- addition to standard 'System.IO.Error.IOError' exceptions, of+-- course).+--+-- The @UnexpectedX@ values are truly exceptional and mean that, while+-- the @sysfs@ attribute for the given pin exists, the contents of the+-- attribute do not match any expected value for that attribute, which+-- probably means that the package is incompatible with the @sysfs@+-- filesystem due to a kernel-level change.+data SysfsException+ = SysfsNotPresent+ -- ^ The @sysfs@ filesystem does not exist+ | SysfsError+ -- ^ Something in the @sysfs@ filesystem does not behave as+ -- expected (could indicate a change in @sysfs@ behavior that the+ -- package does not expect)+ | SysfsPermissionDenied+ -- ^ The @sysfs@ operation is not permitted due to insufficient+ -- permissions+ | PermissionDenied Pin+ -- ^ The operation on the specified pin is not permitted, either+ -- due to insufficient permissions, or because the pin's attribute+ -- cannot be modified (e.g., trying to write to a pin that's+ -- configured for input)+ | InvalidOperation Pin+ -- ^ The operation is invalid for the specified pin, or in the+ -- specified pin's current configuration+ | AlreadyExported Pin+ -- ^ The pin has already been exported+ | InvalidPin Pin+ -- ^ The specified pin does not exist+ | NotExported Pin+ -- ^ The pin has been un-exported or does not exist+ | UnsupportedInputMode PinInputMode Pin+ -- ^ The pin does not support the specified input mode+ | UnsupportedOutputMode PinOutputMode Pin+ -- ^ The pin does not support the specified output mode+ | NoDirectionAttribute Pin+ -- ^ The pin does not have a @direction@ attribute+ | NoEdgeAttribute Pin+ -- ^ The pin does not have an @edge@ attribute+ | UnexpectedDirection Pin String+ -- ^ An unexpected value was read from the pin's @direction@+ -- attribute+ | UnexpectedValue Pin String+ -- ^ An unexpected value was read from the pin's @value@+ -- attribute+ | UnexpectedEdge Pin String+ -- ^ An unexpected value was read from the pin's @edge@+ -- attribute+ | UnexpectedActiveLow Pin String+ -- ^ An unexpected value was read from the pin's @active_low@+ -- attribute+ | UnexpectedContents FilePath String+ -- ^ An unexpected value was read from the specified file+ | InternalError String+ -- ^ An internal error has occurred in the interpreter, something+ -- which should "never happen" and should be reported to the+ -- package maintainer+ deriving (Eq,Show,Typeable)++instance Exception SysfsException where+ toException = gpioExceptionToException+ fromException = gpioExceptionFromException
+ src/System/GPIO/Linux/Sysfs/Util.hs view
@@ -0,0 +1,343 @@+{-|+Module : System.GPIO.Linux.Sysfs.Util+Description : Useful low-level Linux @sysfs@ functions+Copyright : (c) 2016, Drew Hess+License : BSD3+Maintainer : Drew Hess <src@drewhess.com>+Stability : experimental+Portability : non-portable++Useful low-level Linux @sysfs@ functions.++-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Safe #-}++module System.GPIO.Linux.Sysfs.Util+ ( -- * Paths and file names+ sysfsPath+ , exportFileName+ , unexportFileName+ , pinDirName+ , pinActiveLowFileName+ , pinDirectionFileName+ , pinEdgeFileName+ , pinValueFileName+ -- * Convert Haskell types to/from their @sysfs@ representation+ --+ -- | A note on newlines: a Linux GPIO pin's /attributes/+ -- (i.e., the @sysfs@ files representing a pin's state) are+ -- read and written as 'ByteString's. When reading their+ -- contents, the attribute files always return their+ -- (ASCII-encoded) value followed by a newline character+ -- (@\\n@). When writing their contents, the attribute files+ -- will accept their (ASCII-encoded) new value either with or+ -- without a trailing newline character. For consistency (and+ -- for the sake of isomorphic conversions back-and-forth),+ -- these functions always use a trailing newline when+ -- encoding the ASCII value from the Haskell value.+ , pinDirectionToBS+ , pinDirectionValueToBS+ , bsToPinDirection+ , sysfsEdgeToBS+ , bsToSysfsEdge+ , pinValueToBS+ , bsToPinValue+ , activeLowToBS+ , bsToActiveLow+ , intToBS+ , bsToInt+ ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS (empty)+import Data.ByteString.Builder (toLazyByteString, intDec)+import qualified Data.ByteString.Char8 as C8 (readInt)+import qualified Data.ByteString.Lazy as LBS (toStrict)+import System.FilePath ((</>))++import System.GPIO.Types (Pin(..), PinDirection(..), PinValue(..))+import System.GPIO.Linux.Sysfs.Types (SysfsEdge(..))++-- | The base path to Linux's @sysfs@ GPIO filesystem.+--+-- >>> sysfsPath+-- "/sys/class/gpio"+sysfsPath :: FilePath+sysfsPath = "/sys/class/gpio"++-- | The name of the control file used to export GPIO pins via+-- @sysfs@.+--+-- >>> exportFileName+-- "/sys/class/gpio/export"+exportFileName :: FilePath+exportFileName = sysfsPath </> "export"++-- | The name of the control file used to "unexport" GPIO pins via+-- @sysfs@.+--+-- >>> unexportFileName+-- "/sys/class/gpio/unexport"+unexportFileName :: FilePath+unexportFileName = sysfsPath </> "unexport"++-- | Exporting a GPIO pin via @sysfs@ creates a control directory+-- corresponding to that pin. 'pinDirName' gives the name of that+-- directory for a given 'Pin'.+--+-- >>> pinDirName (Pin 16)+-- "/sys/class/gpio/gpio16"+pinDirName :: Pin -> FilePath+pinDirName (Pin n) = sysfsPath </> ("gpio" ++ show n)++-- | The name of the attribute file used to read and write the pin's+-- @active_low@ value.+--+-- >>> pinActiveLowFileName (Pin 16)+-- "/sys/class/gpio/gpio16/active_low"+pinActiveLowFileName :: Pin -> FilePath+pinActiveLowFileName p = pinDirName p </> "active_low"++-- | Pins whose direction can be controlled via @sysfs@ provide a+-- @direction@ attribute file. 'pinDirectionFileName' gives the name+-- of that file for a given 'Pin'. Note that some pins' direction+-- cannot be set. In these cases, the file named by this function does+-- not actually exist.+--+-- >>> pinDirectionFileName (Pin 16)+-- "/sys/class/gpio/gpio16/direction"+pinDirectionFileName :: Pin -> FilePath+pinDirectionFileName p = pinDirName p </> "direction"++-- | Pins that can be configured as interrupt-generating inputs+-- provide an @edge@ attribute file. 'pinEdgeFileName' gives the name+-- of that file for a given 'Pin'. Note that some pins' edge+-- configuration cannot be set. In these cases, the file named by this+-- function does not actually exist.+--+-- >>> pinEdgeFileName (Pin 16)+-- "/sys/class/gpio/gpio16/edge"+pinEdgeFileName :: Pin -> FilePath+pinEdgeFileName p = pinDirName p </> "edge"++-- | The name of the attribute file used to read and write the pin's+-- logical signal value.+--+-- >>> pinValueFileName (Pin 16)+-- "/sys/class/gpio/gpio16/value"+pinValueFileName :: Pin -> FilePath+pinValueFileName p = pinDirName p </> "value"++-- | Convert a 'PinDirection' value to the corresponding 'ByteString'+-- value expected by a pin's @direction@ attribute in the @sysfs@ GPIO+-- filesystem.+--+-- >>> pinDirectionToBS In+-- "in\n"+-- >>> pinDirectionToBS Out+-- "out\n"+pinDirectionToBS :: PinDirection -> ByteString+pinDirectionToBS In = "in\n"+pinDirectionToBS Out = "out\n"++-- | Convert a 'PinValue' value to the corresponding 'ByteString'+-- value expected by a pin's @direction@ attribute in the @sysfs@+-- GPIO, which can be used to configure the pin for output and+-- simultaneously set the pin's (physical) signal level; see the+-- <https://www.kernel.org/doc/Documentation/gpio/sysfs.txt Linux kernel documentation>+-- for details.+--+-- >>> pinDirectionValueToBS Low+-- "low\n"+-- >>> pinDirectionValueToBS High+-- "high\n"+pinDirectionValueToBS :: PinValue -> ByteString+pinDirectionValueToBS Low = "low\n"+pinDirectionValueToBS High = "high\n"++-- | When writing a pin's @direction@ attribute in the @sysfs@ GPIO+-- filesystem with a 'ByteString' value, @in\\n@ configures the pin+-- for input, and @out\\n@ configures the pin for output while also+-- initializing the pin's (physical) signal level to a low value.+--+-- Furthermore, you may write @low\\n@ or @high\\n@ to the+-- @direction@ attribute to configure the pin for output and+-- simulataneously set the pin's physical value.+--+-- Therefore, writing a pin's @direction@ attribute affects not only+-- its direction, but also (potentially) its value. This function's+-- return type reflects that possibility.+--+-- See the+-- <https://www.kernel.org/doc/Documentation/gpio/sysfs.txt Linux kernel documentation>+-- for details.+--+-- This function converts a @direction@ attribute value, encoded as a+-- strict 'ByteString', to its corresponding 'PinDirection' and+-- (possible) 'PinValue' pair; or 'Nothing' if the attribute encoding+-- is invalid.+--+-- >>> :set -XOverloadedStrings+-- >>> bsToPinDirection "in\n"+-- Just (In,Nothing)+-- >>> bsToPinDirection "out\n"+-- Just (Out,Just Low)+-- >>> bsToPinDirection "low\n"+-- Just (Out,Just Low)+-- >>> bsToPinDirection "high\n"+-- Just (Out,Just High)+-- >>> bsToPinDirection "foo\n"+-- Nothing+bsToPinDirection :: ByteString -> Maybe (PinDirection, Maybe PinValue)+bsToPinDirection "in\n" = Just (In, Nothing)+bsToPinDirection "out\n" = Just (Out, Just Low)+bsToPinDirection "low\n" = Just (Out, Just Low)+bsToPinDirection "high\n" = Just (Out, Just High)+bsToPinDirection _ = Nothing++-- | Convert a 'SysfsEdge' value to the 'ByteString' value expected by+-- a pin's @edge@ attribute in the @sysfs@ GPIO filesystem.+--+-- >>> sysfsEdgeToBS None+-- "none\n"+-- >>> sysfsEdgeToBS Rising+-- "rising\n"+-- >>> sysfsEdgeToBS Falling+-- "falling\n"+-- >>> sysfsEdgeToBS Both+-- "both\n"+sysfsEdgeToBS :: SysfsEdge -> ByteString+sysfsEdgeToBS None = "none\n"+sysfsEdgeToBS Rising = "rising\n"+sysfsEdgeToBS Falling = "falling\n"+sysfsEdgeToBS Both = "both\n"++-- | Inverse of 'sysfsEdgeToBS'.+--+-- >>> :set -XOverloadedStrings+-- >>> bsToSysfsEdge "none\n"+-- Just None+-- >>> bsToSysfsEdge "rising\n"+-- Just Rising+-- >>> bsToSysfsEdge "falling\n"+-- Just Falling+-- >>> bsToSysfsEdge "both\n"+-- Just Both+-- >>> bsToSysfsEdge "foo\n"+-- Nothing+bsToSysfsEdge :: ByteString -> Maybe SysfsEdge+bsToSysfsEdge "none\n" = Just None+bsToSysfsEdge "rising\n" = Just Rising+bsToSysfsEdge "falling\n" = Just Falling+bsToSysfsEdge "both\n" = Just Both+bsToSysfsEdge _ = Nothing++-- | Convert a 'PinValue' to the 'ByteString' value expected by a+-- pin's @value@ attribute in the @sysfs@ GPIO filesystem.+--+-- >>> pinValueToBS Low+-- "0\n"+-- >>> pinValueToBS High+-- "1\n"+pinValueToBS :: PinValue -> ByteString+pinValueToBS Low = "0\n"+pinValueToBS High = "1\n"++-- | Convert a @value@ attribute value, encoded as a strict+-- 'ByteString', to its corresponding 'PinValue'.+--+-- Note that the @sysfs@ @value@ attribute is quite liberal: a+-- 'ByteString' value of @0\\n@ will set the pin's (logical) signal+-- level to low, but any other (non-empty) 'ByteString' value will set+-- it to high.+--+-- >>> :set -XOverloadedStrings+-- >>> bsToPinValue "0\n"+-- Just Low+-- >>> bsToPinValue "1\n"+-- Just High+-- >>> bsToPinValue "high\n"+-- Just High+-- >>> bsToPinValue "low\n" -- nota bene!+-- Just High+-- >>> bsToPinValue "foo\n"+-- Just High+-- >>> bsToPinValue ""+-- Nothing+bsToPinValue :: ByteString -> Maybe PinValue+bsToPinValue "0\n" = Just Low+bsToPinValue bs+ | bs == BS.empty = Nothing+ | otherwise = Just High++-- | Convert a 'Bool' to the 'ByteString' value expected by a pin's+-- @active_low@ attribute in the @sysfs@ GPIO filesystem.+--+-- >>> activeLowToBS False+-- "0\n"+-- >>> activeLowToBS True+-- "1\n"+activeLowToBS :: Bool -> ByteString+activeLowToBS False = "0\n"+activeLowToBS True = "1\n"++-- | Convert an @active_low@ attribute value, encoded as a strict+-- 'ByteString', to its corresponding 'Bool' value.+--+-- Note that the @sysfs@ @active_low@ attribute is quite liberal: a+-- 'ByteString' value of @0\\n@ returns 'False' and any other+-- (non-empty) 'ByteString' value returns 'True'.+--+-- >>> :set -XOverloadedStrings+-- >>> bsToActiveLow "0\n"+-- Just False+-- >>> bsToActiveLow "1\n"+-- Just True+-- >>> bsToActiveLow "high\n"+-- Just True+-- >>> bsToActiveLow "low\n" -- nota bene!+-- Just True+-- >>> bsToActiveLow "foo\n"+-- Just True+-- >>> bsToActiveLow ""+-- Nothing+bsToActiveLow :: ByteString -> Maybe Bool+bsToActiveLow "0\n" = Just False+bsToActiveLow bs+ | bs == BS.empty = Nothing+ | otherwise = Just True++-- | Convert an 'Int' to a decimal ASCII encoding in a strict+-- 'ByteString'.+--+-- >>> intToBS 37+-- "37"+intToBS :: Int -> ByteString+intToBS = LBS.toStrict . toLazyByteString . intDec++-- | Convert a strict decimal ASCII 'ByteString' encoding of an+-- integer to an 'Int' (maybe). If there are any extraneous trailing+-- characters after the decimal ASCII encoding, other than a single+-- newline character, this is treated as a failure (unlike+-- 'C8.readInt', which returns the remaining string).+--+-- >>> :set -XOverloadedStrings+-- >>> bsToInt "37"+-- Just 37+-- >>> bsToInt "37\n"+-- Just 37+-- >>> bsToInt "37abc"+-- Nothing+-- >>> bsToInt "37 a"+-- Nothing+bsToInt :: ByteString -> Maybe Int+bsToInt = go . C8.readInt+ where+ go :: Maybe (Int, ByteString) -> Maybe Int+ go (Just (n, bs))+ | bs == BS.empty = Just n+ | bs == "\n" = Just n+ | otherwise = Nothing+ go _ = Nothing
+ src/System/GPIO/Linux/Sysfs/pollSysfs.c view
@@ -0,0 +1,82 @@+/*+ * pollSysfs.c - a poll(2) wrapper for Linux sysfs GPIO.+ *+ * Using poll(2) to wait for GPIO interrupts in Linux sysfs is a bit+ * flaky:+ *+ * - On certain combinations of kernels+hardware, a "dummy read(2)" is+ * needed before the poll(2) operation. As read(2) on a GPIO sysfs+ * pin's "value" attribute doesn't block, it doesn't hurt to do this+ * in all cases, anyway.+ *+ * - The Linux man page for poll(2) states that setting POLLERR in the+ * 'events' field is meaningless. However, the kernel GPIO+ * documentation states: "If you use poll(2), set the events POLLPRI+ * and POLLERR." Here we do what the kernel documentation says.+ *+ * - When poll(2) returns, an lseek(2) is needed before read(2), per+ * the Linux kernel documentation.+ *+ * - It appears that poll(2) on the GPIO sysfs pin's 'value' attribute+ * always returns POLLERR in 'revents', even if there is no error.+ * (This is supposedly true for all sysfs files, not just for GPIO.)+ * We simply ignore that bit and only consider the return value of+ * poll(2) to determine whether an error has occurred. (Presumably,+ * if POLLERR is set and poll(2) returns no error, then the+ * subsequent lseek(2) or read(2) will fail.)+ *+ * This module wraps poll(2) for use with Linux sysfs files by+ * accounting for these quirks.+ *+ * Ref:+ * https://e2e.ti.com/support/dsp/davinci_digital_media_processors/f/716/t/182883+ * http://www.spinics.net/lists/linux-gpio/msg03848.html+ * https://www.kernel.org/doc/Documentation/gpio/sysfs.txt+ * http://stackoverflow.com/questions/16442935/why-doesnt-this-call-to-poll-block-correctly-on-a-sysfs-device-attribute-file+ * http://stackoverflow.com/questions/27411013/poll-returns-both-pollpri-pollerr + */++#include <errno.h>+#include <poll.h>+#include <stdint.h>+#include <unistd.h>++/*+ * Poll a sysfs file descriptor for an event.+ *+ * As this function was written for the Haskell C FFI, and standard+ * practice is for Haskell timeouts/delays to be specified in+ * microseconds, the 'timeout' parameter is specified in microseconds.+ * However, poll(2)'s timeout argument is specified in milliseconds.+ * This function converts the specified microsecond timeout to+ * milliseconds before calling poll(2), but keep in mind that its+ * precision is therefore only millisecond-accurate.+ *+ * As with poll(2), if 'timeout' is negative, then the timeout is+ * disabled.+ *+ * This function may block, so when calling it from Haskell, you+ * should use the interruptible variant of the C FFI. Therefore, the+ * function may return EINTR and you should be prepared to re-try it+ * in this case.+ */+int pollSysfs(int fd, int timeout)+{+ uint8_t dummy;+ if (read(fd, &dummy, 1) == -1) {+ return -1;+ }++ struct pollfd fds = { .fd = fd, .events = POLLPRI|POLLERR, .revents = 0 };++ int timeout_in_ms = (timeout > 0) ? (timeout / 1000) : timeout;++ int poll_result = poll(&fds, 1, timeout_in_ms);+ if (poll_result == -1) {+ return -1;+ }+ if (lseek(fds.fd, 0, SEEK_SET) == -1) {+ return -1;+ }+ return poll_result;+}
+ src/System/GPIO/Monad.hs view
@@ -0,0 +1,833 @@+{-|+Module : System.GPIO.Monad+Description : A monad for GPIO computations+Copyright : (c) 2016, Drew Hess+License : BSD3+Maintainer : Drew Hess <src@drewhess.com>+Stability : experimental+Portability : non-portable++A monadic context for GPIO computations.++-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE Safe #-}++module System.GPIO.Monad+ ( -- * GPIO types+ --+ -- | For your convenience, the following types are+ -- re-exported from the "System.GPIO.Types" module.+ Pin(..)+ , pinNumber+ , PinInputMode(..)+ , PinOutputMode(..)+ , PinCapabilities(..)+ , PinDirection(..)+ , PinActiveLevel(..)+ , PinValue(..)+ , PinInterruptMode(..)++ -- * MonadGpio class+ , MonadGpio(..)+ , withPin++ -- * Safer types+ --+ -- | If you can restrict your use of a particular pin to just+ -- one mode of operation (input, interrupt-driven input, or+ -- output), you can achieve better type-safety than is+ -- possible with the fully-general 'Pin' type by using the+ -- one of the following more limited types and its+ -- corresponding actions.+ --+ -- == A caveat+ --+ -- On some GPIO platforms (e.g., Linux @sysfs@), no provision+ -- is made for opening pins in "exclusive mode," and as such,+ -- pins can be opened and configured by any number of+ -- processes on the system other than our own programs.+ -- Therefore, even when using these safer types, a robust+ -- @hpio@ program should still be prepared to deal with+ -- configuration-related errors in case another process+ -- re-configures a pin while the @hpio@ program is using it.+ --+ -- In other words, even when using these safer types, you+ -- should still be prepared to handle the full range of+ -- 'System.GPIO.Types.SomeGpioException's.+ , InputPin+ , withInputPin+ , readInputPin+ , getInputPinInputMode+ , getInputPinActiveLevel+ , setInputPinActiveLevel+ , toggleInputPinActiveLevel+ , InterruptPin+ , withInterruptPin+ , readInterruptPin+ , pollInterruptPin+ , pollInterruptPinTimeout+ , getInterruptPinInputMode+ , getInterruptPinInterruptMode+ , setInterruptPinInterruptMode+ , getInterruptPinActiveLevel+ , setInterruptPinActiveLevel+ , toggleInterruptPinActiveLevel+ , OutputPin+ , withOutputPin+ , writeOutputPin+ , toggleOutputPin+ , readOutputPin+ , getOutputPinOutputMode+ , getOutputPinActiveLevel+ , setOutputPinActiveLevel+ , toggleOutputPinActiveLevel++ -- * The GPIO exception hierarchy+ --+ -- | Re-exported from "System.GPIO.Types".+ , SomeGpioException(..)+ , gpioExceptionToException+ , gpioExceptionFromException+ ) where++import Prelude ()+import Prelude.Compat+import Control.Monad.Catch (MonadMask, MonadThrow, bracket)+import Control.Monad.Catch.Pure (CatchT)+import Control.Monad.Trans.Cont (ContT)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Reader (ReaderT)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Identity (IdentityT)+import Control.Monad.Trans.List (ListT)+import Control.Monad.Trans.Maybe (MaybeT)+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS (RWST)+import qualified Control.Monad.Trans.RWS.Strict as StrictRWS (RWST)+import qualified Control.Monad.Trans.State.Lazy as LazyState (StateT)+import qualified Control.Monad.Trans.State.Strict as StrictState (StateT)+import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter (WriterT)+import qualified Control.Monad.Trans.Writer.Strict as StrictWriter (WriterT)++import System.GPIO.Types+ (Pin(..), PinInputMode(..), PinOutputMode(..), PinCapabilities(..),+ PinActiveLevel(..), PinDirection(..), PinInterruptMode(..),+ PinValue(..), SomeGpioException(..), gpioExceptionToException,+ gpioExceptionFromException, pinNumber)++-- | A monad type class for GPIO computations. The type class+-- specifies a DSL for writing portable GPIO programs, and instances+-- of the type class provide the interpreter needed to run these+-- programs on a particular GPIO platform.+--+-- In the type signature, 'h' represents a (platform-dependent)+-- abstract pin handle for operating on opened pins. It is analogous+-- to a file handle.+--+-- == Active-high versus active-low logic+--+-- The DSL supports both /active-high/ and /active-low/ logic. That+-- is, the /active level/ of a GPIO pin can be configured as+-- 'ActiveHigh' or 'ActiveLow'. If a pin's active level is+-- 'ActiveHigh', then for that pin, a 'PinValue' of 'High' corresponds+-- to a "high" physical signal level, and a 'PinValue' of 'Low'+-- corresponds to a "low" physical signal level. The converse is true+-- when the pin's active level is 'ActiveLow'.+--+-- Despite the potential confusion, the advantage of supporting+-- active-low logic is that you can, if you choose, write your program+-- in terms of "positive" logic (where 'High' always means "on" and+-- 'Low' always means "off"), and, with the same program, interface+-- with either positive (active-high) or negative (active-low) logic+-- simply by setting the pin's active level before running the+-- program.+--+-- In the documentation for this package, whenever you see a reference+-- to a "pin value" or "signal level," unless otherwise noted, we mean+-- the /logical/ value or level, not the /physical/ value or level;+-- that is, we mean the abstract notion of the pin being "on" or+-- "off," independent of the voltage level seen on the physical pin.+-- If the pin is configured as active-high, then the logical and+-- physical values are one and the same; if not, they are the inverse+-- of each other.+--+-- Note that the active-high/active-low setting is per-pin; each pin's+-- active level is independent of the others.+--+-- Not all platforms natively support active-low logic. On platforms+-- without native support, the platform interpreter will invert values+-- (both read and written) in software when a pin is configured as+-- active-low.++class Monad m => MonadGpio h m | m -> h where++ -- | Get a list of available GPIO pins on the system.+ --+ -- This command makes a best-effort attempt to find the available+ -- pins, but some systems may not make the complete list available at+ -- runtime. Therefore, there may be more pins available than are+ -- returned by this action.+ pins :: m [Pin]++ -- | Query the pin's capabilities.+ pinCapabilities :: Pin -> m PinCapabilities++ -- | Open a pin for use and return a handle to it.+ --+ -- Note that on some platforms (notably Linux), pin handles are+ -- global resources and it is, strictly speaking, an error to+ -- attempt to open a pin which has already been opened. However,+ -- because there is generally no way to perform an atomic "only open+ -- the pin if it hasn't already been opened" operation on such+ -- platforms, this action will squash that particular error on those+ -- platforms and return the global handle anyway, without making any+ -- other state changes to the already-opened pin.+ --+ -- Keep in mind, however, that on these platforms where pin handles+ -- are global resources, closing one pin handle will effectively+ -- invalidate all other handles for the same pin. Be very careful to+ -- coordinate the opening and closing of pins if you are operating+ -- on the same pin in multiple threads.+ openPin :: Pin -> m h++ -- | Close the pin; i.e., indicate to the system that you no longer+ -- intend to use the pin via the given handle.+ --+ -- Note that on some platforms (notably Linux), pin handles are+ -- global resources and it is, strictly speaking, an error to+ -- attempt to close a pin which has already been closed via another+ -- handle to the same pin. However, this action will squash that+ -- error on those platforms and will simply return without making+ -- any changes to the GPIO environment.+ --+ -- Keep in mind, however, that on these platforms where pin handles+ -- are global resources, opening multiple handles for the same pin+ -- and then closing one of those handles will render all other+ -- handles for the same pin invalid. Be very careful to coordinate+ -- the opening and closing of pins if you are operating on the same+ -- pin in multiple threads.+ --+ -- Note that there are also platforms (again, notably certain Linux+ -- systems) where some pins are effectively always open and cannot+ -- be closed. Invoking this action on such a pin will squash any+ -- error that occurs when attempting to close the pin, and the+ -- action will simply return without making any changes to the GPIO+ -- environment.+ closePin :: h -> m ()++ -- | Get the pin's currently configured direction.+ --+ -- Note that there is no @setPinDirection@ action. You set the pin's+ -- direction indirectly by setting its input mode or output mode via+ -- 'setPinInputMode' and 'setPinOutputMode', respectively.+ --+ -- Rarely, a particular pin's direction may not be available in a+ -- cross-platform way. In these cases, calling this action is an+ -- error. In general, though, if the pin's capabilities indicate+ -- that it supports at least one 'PinInputMode' or 'PinOutputMode',+ -- it's safe to call this action.+ getPinDirection :: h -> m PinDirection++ -- | Get the pin's input mode.+ --+ -- If the pin is not currently configured for input, it's an error+ -- to call this action.+ getPinInputMode :: h -> m PinInputMode++ -- | Set the pin's input mode. This action will also set the pin's+ -- direction to 'In'.+ --+ -- It is an error to call this action if the given pin does not+ -- support the given input mode.+ setPinInputMode :: h -> PinInputMode -> m ()++ -- | Get the pin's output mode.+ --+ -- If the pin is not currently configured for output, it's an error+ -- to call this action.+ getPinOutputMode :: h -> m PinOutputMode++ -- | Set the pin's output mode and value. This action will also set+ -- the pin's direction to 'Out'+ --+ -- If the pin is already in output mode and you only want to change+ -- its value, use 'writePin'.+ --+ -- It is an error to call this action if the given pin does not+ -- support the given output mode.+ setPinOutputMode :: h -> PinOutputMode -> PinValue -> m ()++ -- | Read the pin's value.+ --+ -- Note that this action never blocks.+ readPin :: h -> m PinValue++ -- | Block the current thread until an event occurs on the pin which+ -- corresponds to the pin's current interrupt mode. Upon detection+ -- of the event, return the pin's value.+ --+ -- If the pin does not support interrupts, then this action's+ -- behavior is plaform-dependent.+ --+ -- It is an error to call this action when the pin is not configured+ -- for input.+ --+ -- Note: due to its interaction with the threading system, this+ -- action may behave differently across different implementations of+ -- Haskell. It has only been tested with GHC. (On GHC, you should+ -- compile any program that uses this action with the @-threaded@+ -- option.)+ pollPin :: h -> m PinValue++ -- | Same as 'pollPin', except with a timeout, specified in+ -- microseconds. If no event occurs before the timeout expires, this+ -- action returns 'Nothing'; otherwise, it returns the pin's signal+ -- level wrapped in a 'Just'.+ --+ -- If the timeout value is negative, this action behaves just like+ -- 'pollPin'.+ --+ -- If the pin does not support interrupts, then this action's+ -- behavior is platform-dependent.+ --+ -- It is an error to call this action when the pin is not configured+ -- for input.+ --+ -- Note: due to its interaction with the threading system, this+ -- action may behave differently across different implementations of+ -- Haskell. It has only been tested with GHC. (On GHC, you should+ -- compile any program that uses this action with the @-threaded@+ -- option.)+ pollPinTimeout :: h -> Int -> m (Maybe PinValue)++ -- | Set the pin's output value.+ --+ -- It is an error to call this action when the pin is not configured+ -- for output.+ writePin :: h -> PinValue -> m ()++ -- | Toggle the pin's output value and return the pin's new output+ -- value.+ --+ -- It is an error to call this action when the pin is not configured+ -- for output.+ togglePin :: h -> m PinValue++ -- | Get the pin's interrupt mode.+ --+ -- If the pin does not support interrupts, it is an error to call+ -- this action.+ --+ -- (Note that 'RisingEdge' and 'FallingEdge' are relative to the+ -- pin's active level; i.e., they refer to the pin's /logical/+ -- signal edges, not its physical signal edges.)+ getPinInterruptMode :: h -> m PinInterruptMode++ -- | Set the pin's interrupt mode (only when the pin is configured+ -- for input).+ --+ -- A pin's interrupt mode determines the behavior of the 'pollPin'+ -- and 'pollPinTimeout' actions. Those actions will block the+ -- current thread on an input pin until a particular event occurs on+ -- that pin's signal waveform: a low-to-high transition+ -- ('RisingEdge'), a high-to-low transition ('FallingEdge'), or any+ -- change of level ('Level').+ --+ -- You can also disable interrupts on the pin so that 'pollPin' will+ -- block the current thread indefinitely (or until a timer expires,+ -- in the case of 'pollPinTimeout'). This functionality is useful+ -- when, for example, one thread is dedicated to servicing+ -- interrupts on a pin, and another thread wants to mask interrupts+ -- on that pin for some period of time.+ --+ -- Some pins (or even some GPIO platforms) may not support+ -- interrupts. In such cases, it is an error to call this action.+ --+ -- It is an error to use this action on a pin configured for output.+ setPinInterruptMode :: h -> PinInterruptMode -> m ()++ -- | Get the pin's active level.+ getPinActiveLevel :: h -> m PinActiveLevel++ -- | Set the pin's active level.+ setPinActiveLevel :: h -> PinActiveLevel -> m ()++ -- | Toggle the pin's active level. Returns the pin's new level.+ togglePinActiveLevel :: h -> m PinActiveLevel++instance (MonadGpio h m) => MonadGpio h (IdentityT m) where+ pins = lift pins+ pinCapabilities = lift . pinCapabilities+ openPin = lift . openPin+ closePin = lift . closePin+ getPinDirection = lift . getPinDirection+ getPinInputMode = lift . getPinInputMode+ setPinInputMode h mode = lift $ setPinInputMode h mode+ getPinOutputMode = lift . getPinOutputMode+ setPinOutputMode h mode v = lift $ setPinOutputMode h mode v+ readPin = lift . readPin+ pollPin = lift . readPin+ pollPinTimeout h to = lift $ pollPinTimeout h to+ writePin h v = lift $ writePin h v+ togglePin = lift . togglePin+ getPinInterruptMode = lift . getPinInterruptMode+ setPinInterruptMode h mode = lift $ setPinInterruptMode h mode+ getPinActiveLevel = lift . getPinActiveLevel+ setPinActiveLevel h v = lift $ setPinActiveLevel h v+ togglePinActiveLevel = lift . togglePinActiveLevel++instance (MonadGpio h m) => MonadGpio h (ContT r m) where+ pins = lift pins+ pinCapabilities = lift . pinCapabilities+ openPin = lift . openPin+ closePin = lift . closePin+ getPinDirection = lift . getPinDirection+ getPinInputMode = lift . getPinInputMode+ setPinInputMode h mode = lift $ setPinInputMode h mode+ getPinOutputMode = lift . getPinOutputMode+ setPinOutputMode h mode v = lift $ setPinOutputMode h mode v+ readPin = lift . readPin+ pollPin = lift . readPin+ pollPinTimeout h to = lift $ pollPinTimeout h to+ writePin h v = lift $ writePin h v+ togglePin = lift . togglePin+ getPinInterruptMode = lift . getPinInterruptMode+ setPinInterruptMode h mode = lift $ setPinInterruptMode h mode+ getPinActiveLevel = lift . getPinActiveLevel+ setPinActiveLevel h v = lift $ setPinActiveLevel h v+ togglePinActiveLevel = lift . togglePinActiveLevel++instance (MonadGpio h m) => MonadGpio h (CatchT m) where+ pins = lift pins+ pinCapabilities = lift . pinCapabilities+ openPin = lift . openPin+ closePin = lift . closePin+ getPinDirection = lift . getPinDirection+ getPinInputMode = lift . getPinInputMode+ setPinInputMode h mode = lift $ setPinInputMode h mode+ getPinOutputMode = lift . getPinOutputMode+ setPinOutputMode h mode v = lift $ setPinOutputMode h mode v+ readPin = lift . readPin+ pollPin = lift . readPin+ pollPinTimeout h to = lift $ pollPinTimeout h to+ writePin h v = lift $ writePin h v+ togglePin = lift . togglePin+ getPinInterruptMode = lift . getPinInterruptMode+ setPinInterruptMode h mode = lift $ setPinInterruptMode h mode+ getPinActiveLevel = lift . getPinActiveLevel+ setPinActiveLevel h v = lift $ setPinActiveLevel h v+ togglePinActiveLevel = lift . togglePinActiveLevel++instance (MonadGpio h m) => MonadGpio h (ExceptT e m) where+ pins = lift pins+ pinCapabilities = lift . pinCapabilities+ openPin = lift . openPin+ closePin = lift . closePin+ getPinDirection = lift . getPinDirection+ getPinInputMode = lift . getPinInputMode+ setPinInputMode h mode = lift $ setPinInputMode h mode+ getPinOutputMode = lift . getPinOutputMode+ setPinOutputMode h mode v = lift $ setPinOutputMode h mode v+ readPin = lift . readPin+ pollPin = lift . readPin+ pollPinTimeout h to = lift $ pollPinTimeout h to+ writePin h v = lift $ writePin h v+ togglePin = lift . togglePin+ getPinInterruptMode = lift . getPinInterruptMode+ setPinInterruptMode h mode = lift $ setPinInterruptMode h mode+ getPinActiveLevel = lift . getPinActiveLevel+ setPinActiveLevel h v = lift $ setPinActiveLevel h v+ togglePinActiveLevel = lift . togglePinActiveLevel++instance (MonadGpio h m) => MonadGpio h (ListT m) where+ pins = lift pins+ pinCapabilities = lift . pinCapabilities+ openPin = lift . openPin+ closePin = lift . closePin+ getPinDirection = lift . getPinDirection+ getPinInputMode = lift . getPinInputMode+ setPinInputMode h mode = lift $ setPinInputMode h mode+ getPinOutputMode = lift . getPinOutputMode+ setPinOutputMode h mode v = lift $ setPinOutputMode h mode v+ readPin = lift . readPin+ pollPin = lift . readPin+ pollPinTimeout h to = lift $ pollPinTimeout h to+ writePin h v = lift $ writePin h v+ togglePin = lift . togglePin+ getPinInterruptMode = lift . getPinInterruptMode+ setPinInterruptMode h mode = lift $ setPinInterruptMode h mode+ getPinActiveLevel = lift . getPinActiveLevel+ setPinActiveLevel h v = lift $ setPinActiveLevel h v+ togglePinActiveLevel = lift . togglePinActiveLevel++instance (MonadGpio h m) => MonadGpio h (MaybeT m) where+ pins = lift pins+ pinCapabilities = lift . pinCapabilities+ openPin = lift . openPin+ closePin = lift . closePin+ getPinDirection = lift . getPinDirection+ getPinInputMode = lift . getPinInputMode+ setPinInputMode h mode = lift $ setPinInputMode h mode+ getPinOutputMode = lift . getPinOutputMode+ setPinOutputMode h mode v = lift $ setPinOutputMode h mode v+ readPin = lift . readPin+ pollPin = lift . readPin+ pollPinTimeout h to = lift $ pollPinTimeout h to+ writePin h v = lift $ writePin h v+ togglePin = lift . togglePin+ getPinInterruptMode = lift . getPinInterruptMode+ setPinInterruptMode h mode = lift $ setPinInterruptMode h mode+ getPinActiveLevel = lift . getPinActiveLevel+ setPinActiveLevel h v = lift $ setPinActiveLevel h v+ togglePinActiveLevel = lift . togglePinActiveLevel++instance (MonadGpio h m) => MonadGpio h (ReaderT r m) where+ pins = lift pins+ pinCapabilities = lift . pinCapabilities+ openPin = lift . openPin+ closePin = lift . closePin+ getPinDirection = lift . getPinDirection+ getPinInputMode = lift . getPinInputMode+ setPinInputMode h mode = lift $ setPinInputMode h mode+ getPinOutputMode = lift . getPinOutputMode+ setPinOutputMode h mode v = lift $ setPinOutputMode h mode v+ readPin = lift . readPin+ pollPin = lift . readPin+ pollPinTimeout h to = lift $ pollPinTimeout h to+ writePin h v = lift $ writePin h v+ togglePin = lift . togglePin+ getPinInterruptMode = lift . getPinInterruptMode+ setPinInterruptMode h mode = lift $ setPinInterruptMode h mode+ getPinActiveLevel = lift . getPinActiveLevel+ setPinActiveLevel h v = lift $ setPinActiveLevel h v+ togglePinActiveLevel = lift . togglePinActiveLevel++instance (MonadGpio h m, Monoid w) => MonadGpio h (LazyRWS.RWST r w s m) where+ pins = lift pins+ pinCapabilities = lift . pinCapabilities+ openPin = lift . openPin+ closePin = lift . closePin+ getPinDirection = lift . getPinDirection+ getPinInputMode = lift . getPinInputMode+ setPinInputMode h mode = lift $ setPinInputMode h mode+ getPinOutputMode = lift . getPinOutputMode+ setPinOutputMode h mode v = lift $ setPinOutputMode h mode v+ readPin = lift . readPin+ pollPin = lift . readPin+ pollPinTimeout h to = lift $ pollPinTimeout h to+ writePin h v = lift $ writePin h v+ togglePin = lift . togglePin+ getPinInterruptMode = lift . getPinInterruptMode+ setPinInterruptMode h mode = lift $ setPinInterruptMode h mode+ getPinActiveLevel = lift . getPinActiveLevel+ setPinActiveLevel h v = lift $ setPinActiveLevel h v+ togglePinActiveLevel = lift . togglePinActiveLevel++instance (MonadGpio h m, Monoid w) => MonadGpio h (StrictRWS.RWST r w s m) where+ pins = lift pins+ pinCapabilities = lift . pinCapabilities+ openPin = lift . openPin+ closePin = lift . closePin+ getPinDirection = lift . getPinDirection+ getPinInputMode = lift . getPinInputMode+ setPinInputMode h mode = lift $ setPinInputMode h mode+ getPinOutputMode = lift . getPinOutputMode+ setPinOutputMode h mode v = lift $ setPinOutputMode h mode v+ readPin = lift . readPin+ pollPin = lift . readPin+ pollPinTimeout h to = lift $ pollPinTimeout h to+ writePin h v = lift $ writePin h v+ togglePin = lift . togglePin+ getPinInterruptMode = lift . getPinInterruptMode+ setPinInterruptMode h mode = lift $ setPinInterruptMode h mode+ getPinActiveLevel = lift . getPinActiveLevel+ setPinActiveLevel h v = lift $ setPinActiveLevel h v+ togglePinActiveLevel = lift . togglePinActiveLevel++instance (MonadGpio h m) => MonadGpio h (LazyState.StateT s m) where+ pins = lift pins+ pinCapabilities = lift . pinCapabilities+ openPin = lift . openPin+ closePin = lift . closePin+ getPinDirection = lift . getPinDirection+ getPinInputMode = lift . getPinInputMode+ setPinInputMode h mode = lift $ setPinInputMode h mode+ getPinOutputMode = lift . getPinOutputMode+ setPinOutputMode h mode v = lift $ setPinOutputMode h mode v+ readPin = lift . readPin+ pollPin = lift . readPin+ pollPinTimeout h to = lift $ pollPinTimeout h to+ writePin h v = lift $ writePin h v+ togglePin = lift . togglePin+ getPinInterruptMode = lift . getPinInterruptMode+ setPinInterruptMode h mode = lift $ setPinInterruptMode h mode+ getPinActiveLevel = lift . getPinActiveLevel+ setPinActiveLevel h v = lift $ setPinActiveLevel h v+ togglePinActiveLevel = lift . togglePinActiveLevel++instance (MonadGpio h m) => MonadGpio h (StrictState.StateT s m) where+ pins = lift pins+ pinCapabilities = lift . pinCapabilities+ openPin = lift . openPin+ closePin = lift . closePin+ getPinDirection = lift . getPinDirection+ getPinInputMode = lift . getPinInputMode+ setPinInputMode h mode = lift $ setPinInputMode h mode+ getPinOutputMode = lift . getPinOutputMode+ setPinOutputMode h mode v = lift $ setPinOutputMode h mode v+ readPin = lift . readPin+ pollPin = lift . readPin+ pollPinTimeout h to = lift $ pollPinTimeout h to+ writePin h v = lift $ writePin h v+ togglePin = lift . togglePin+ getPinInterruptMode = lift . getPinInterruptMode+ setPinInterruptMode h mode = lift $ setPinInterruptMode h mode+ getPinActiveLevel = lift . getPinActiveLevel+ setPinActiveLevel h v = lift $ setPinActiveLevel h v+ togglePinActiveLevel = lift . togglePinActiveLevel++instance (MonadGpio h m, Monoid w) => MonadGpio h (LazyWriter.WriterT w m) where+ pins = lift pins+ pinCapabilities = lift . pinCapabilities+ openPin = lift . openPin+ closePin = lift . closePin+ getPinDirection = lift . getPinDirection+ getPinInputMode = lift . getPinInputMode+ setPinInputMode h mode = lift $ setPinInputMode h mode+ getPinOutputMode = lift . getPinOutputMode+ setPinOutputMode h mode v = lift $ setPinOutputMode h mode v+ readPin = lift . readPin+ pollPin = lift . readPin+ pollPinTimeout h to = lift $ pollPinTimeout h to+ writePin h v = lift $ writePin h v+ togglePin = lift . togglePin+ getPinInterruptMode = lift . getPinInterruptMode+ setPinInterruptMode h mode = lift $ setPinInterruptMode h mode+ getPinActiveLevel = lift . getPinActiveLevel+ setPinActiveLevel h v = lift $ setPinActiveLevel h v+ togglePinActiveLevel = lift . togglePinActiveLevel++instance (MonadGpio h m, Monoid w) => MonadGpio h (StrictWriter.WriterT w m) where+ pins = lift pins+ pinCapabilities = lift . pinCapabilities+ openPin = lift . openPin+ closePin = lift . closePin+ getPinDirection = lift . getPinDirection+ getPinInputMode = lift . getPinInputMode+ setPinInputMode h mode = lift $ setPinInputMode h mode+ getPinOutputMode = lift . getPinOutputMode+ setPinOutputMode h mode v = lift $ setPinOutputMode h mode v+ readPin = lift . readPin+ pollPin = lift . readPin+ pollPinTimeout h to = lift $ pollPinTimeout h to+ writePin h v = lift $ writePin h v+ togglePin = lift . togglePin+ getPinInterruptMode = lift . getPinInterruptMode+ setPinInterruptMode h mode = lift $ setPinInterruptMode h mode+ getPinActiveLevel = lift . getPinActiveLevel+ setPinActiveLevel h v = lift $ setPinActiveLevel h v+ togglePinActiveLevel = lift . togglePinActiveLevel++-- | Exception-safe pin management.+--+-- 'withPin' opens a pin using 'openPin' and passes the handle to the+-- given GPIO computation. Upon completion of the computation, or an+-- exception occuring within the computation, 'withPin' closes the+-- handle using 'closePin' and then propagates the result, either by+-- returning the value of the computation or by re-raising the+-- exception.+withPin :: (MonadMask m, MonadGpio h m) => Pin -> (h -> m a) -> m a+withPin p = bracket (openPin p) closePin++-- | A handle to a pin that's been configured for non-blocking reads+-- only.+--+-- You cannot poll an 'InputPin' for interrupts. See 'InterruptPin'.+newtype InputPin h =+ InputPin {_inputHandle :: h}+ deriving (Eq,Show)++maybeSetPinActiveLevel :: (MonadGpio h m) => h -> Maybe PinActiveLevel -> m ()+maybeSetPinActiveLevel _ Nothing = return ()+maybeSetPinActiveLevel h (Just v) = setPinActiveLevel h v++-- | Like 'withPin', but for 'InputPin's. Sets the pin's input mode to+-- the specified 'PinInputMode' value.+--+-- If the optional active level argument is 'Nothing', then the pin's+-- active level is unchanged from its current state. Otherwise, the+-- pin's active level is set to the specified level.+--+-- It is an error to call this action if the pin cannot be configured+-- for input, or if it does not support the specified input mode.+withInputPin :: (MonadMask m, MonadGpio h m) => Pin -> PinInputMode -> Maybe PinActiveLevel -> (InputPin h -> m a) -> m a+withInputPin p mode l action =+ withPin p $ \h ->+ do setPinInputMode h mode+ maybeSetPinActiveLevel h l+ action $ InputPin h++-- | Like 'readPin'.+readInputPin :: (MonadGpio h m) => InputPin h -> m PinValue+readInputPin p =+ readPin (_inputHandle p)++-- | Like 'getPinInputMode'.+getInputPinInputMode :: (MonadGpio h m) => InputPin h -> m PinInputMode+getInputPinInputMode p =+ getPinInputMode (_inputHandle p)++-- | Like 'getPinActiveLevel'.+getInputPinActiveLevel :: (MonadGpio h m) => InputPin h -> m PinActiveLevel+getInputPinActiveLevel p =+ getPinActiveLevel (_inputHandle p)++-- | Like 'setPinActiveLevel'.+setInputPinActiveLevel :: (MonadGpio h m) => InputPin h -> PinActiveLevel -> m ()+setInputPinActiveLevel p =+ setPinActiveLevel (_inputHandle p)++-- | Like 'togglePinActiveLevel'.+toggleInputPinActiveLevel :: (MonadGpio h m) => InputPin h -> m PinActiveLevel+toggleInputPinActiveLevel p =+ togglePinActiveLevel (_inputHandle p)++-- | A handle to a pin that's been configured both for non-blocking+-- reads and for interrupt-driven polling reads.+newtype InterruptPin h =+ InterruptPin {_interruptHandle :: h}+ deriving (Eq,Show)++-- | Like 'withPin', but for 'InterruptPin's. The pin is opened for+-- input, is input mode is set to the specified 'PinInputMode' value,+-- and its interrupt mode is set to the specified 'PinInterruptMode'+-- value.+--+-- If the optional active level argument is 'Nothing', then the pin's+-- active level is unchanged from its current state. Otherwise, the+-- pin's active level is set to the specified level.+--+-- It is an error to call this action if any of the following are true:+--+-- * The pin cannot be configured for input.+--+-- * The pin does not support the specified input mode.+--+-- * The pin does not support interrupts.+withInterruptPin :: (MonadMask m, MonadGpio h m) => Pin -> PinInputMode -> PinInterruptMode -> Maybe PinActiveLevel -> (InterruptPin h -> m a) -> m a+withInterruptPin p inputMode interruptMode l action =+ withPin p $ \h ->+ do setPinInputMode h inputMode+ setPinInterruptMode h interruptMode+ maybeSetPinActiveLevel h l+ action $ InterruptPin h++-- | Like 'readPin'.+readInterruptPin :: (MonadGpio h m) => InterruptPin h -> m PinValue+readInterruptPin p =+ readPin (_interruptHandle p)++-- | Like 'pollPin'.+pollInterruptPin :: (MonadGpio h m) => InterruptPin h -> m PinValue+pollInterruptPin p =+ pollPin (_interruptHandle p)++-- | Like 'pollPinTimeout'.+pollInterruptPinTimeout :: (MonadGpio h m) => InterruptPin h -> Int -> m (Maybe PinValue)+pollInterruptPinTimeout p =+ pollPinTimeout (_interruptHandle p)++-- | Like 'getPinInputMode'.+getInterruptPinInputMode :: (MonadGpio h m) => InterruptPin h -> m PinInputMode+getInterruptPinInputMode p =+ getPinInputMode (_interruptHandle p)++-- | Like 'getPinInterruptMode'.+getInterruptPinInterruptMode :: (MonadThrow m, MonadGpio h m) => InterruptPin h -> m PinInterruptMode+getInterruptPinInterruptMode p =+ getPinInterruptMode (_interruptHandle p)++-- | Like 'setPinInterruptMode'.+setInterruptPinInterruptMode :: (MonadGpio h m) => InterruptPin h -> PinInterruptMode -> m ()+setInterruptPinInterruptMode p =+ setPinInterruptMode (_interruptHandle p)++-- | Like 'getPinActiveLevel'.+getInterruptPinActiveLevel :: (MonadGpio h m) => InterruptPin h -> m PinActiveLevel+getInterruptPinActiveLevel p =+ getPinActiveLevel (_interruptHandle p)++-- | Like 'setPinActiveLevel'.+setInterruptPinActiveLevel :: (MonadGpio h m) => InterruptPin h -> PinActiveLevel -> m ()+setInterruptPinActiveLevel p =+ setPinActiveLevel (_interruptHandle p)++-- | Like 'togglePinActiveLevel'.+toggleInterruptPinActiveLevel :: (MonadGpio h m) => InterruptPin h -> m PinActiveLevel+toggleInterruptPinActiveLevel p =+ togglePinActiveLevel (_interruptHandle p)++-- | A handle to a pin that's been configured for output only.+--+-- Note that output pins can be both read and written. However, they+-- only support non-blocking reads, not interrupt-driven polling+-- reads.+newtype OutputPin h =+ OutputPin {_outputHandle :: h}+ deriving (Eq,Show)++-- | Like 'withPin', but for 'OutputPin's. Sets the pin's output mode+-- to the specified 'PinOutputMode' value.+--+-- The 'PinValue' argument specifies the pin's initial output value.+-- It is relative to the active level argument, or to the pin's+-- current active level if the active level argument is 'Nothing'.+--+-- It is an error to call this action if the pin cannot be configured+-- for output, or if it does not support the specified output mode.+withOutputPin :: (MonadMask m, MonadGpio h m) => Pin -> PinOutputMode -> Maybe PinActiveLevel -> PinValue -> (OutputPin h -> m a) -> m a+withOutputPin p mode l v action =+ withPin p $ \h ->+ do maybeSetPinActiveLevel h l+ setPinOutputMode h mode v+ action $ OutputPin h++-- | Like 'writePin'.+writeOutputPin :: (MonadGpio h m) => OutputPin h -> PinValue -> m ()+writeOutputPin p =+ writePin (_outputHandle p)++-- | Like 'togglePin'.+toggleOutputPin :: (MonadGpio h m) => OutputPin h -> m PinValue+toggleOutputPin p =+ togglePin (_outputHandle p)++-- | Like 'readPin'.+readOutputPin :: (MonadGpio h m) => OutputPin h -> m PinValue+readOutputPin p =+ readPin (_outputHandle p)++-- | Like 'getPinOutputMode'.+getOutputPinOutputMode :: (MonadGpio h m) => OutputPin h -> m PinOutputMode+getOutputPinOutputMode p =+ getPinOutputMode (_outputHandle p)++-- | Like 'getPinActiveLevel'.+getOutputPinActiveLevel :: (MonadGpio h m) => OutputPin h -> m PinActiveLevel+getOutputPinActiveLevel p =+ getPinActiveLevel (_outputHandle p)++-- | Like 'setPinActiveLevel'.+setOutputPinActiveLevel :: (MonadGpio h m) => OutputPin h -> PinActiveLevel -> m ()+setOutputPinActiveLevel p =+ setPinActiveLevel (_outputHandle p)++-- | Like 'togglePinActiveLevel'.+toggleOutputPinActiveLevel :: (MonadGpio h m) => OutputPin h -> m PinActiveLevel+toggleOutputPinActiveLevel p =+ togglePinActiveLevel (_outputHandle p)
+ src/System/GPIO/Tutorial.hs view
@@ -0,0 +1,1369 @@+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-unused-binds #-}++module System.GPIO.Tutorial (+ -- * Introduction+ -- $introduction++ -- * Terminology and types+ --+ -- Let's define some terms that will be used throughout this tutorial.+ -- $pin+ Pin(..)++ -- $pin_value+ , PinValue(..)+ , PinActiveLevel(..)++ -- $pin_direction+ , PinDirection(..)+ , PinInputMode(..)+ , PinOutputMode(..)++ -- $pin_interrupt_mode+ , PinInterruptMode(..)++ -- $pin_capabilities+ , PinCapabilities(..)++ -- * Interpreters+ -- $interpreters++ -- * A mock interpreter+ -- $mock_interpreter+ , runTutorial++ -- * Basic pin operations+ -- $basic_pin_operations++ -- * Reading and writing pins+ -- $reading_and_writing++ -- * Better type-safety+ -- $pin_types++ , InputPin+ , withInputPin+ -- $input_pins+ , InterruptPin+ , withInterruptPin+ -- $interrupt_pins+ , OutputPin+ , withOutputPin+ -- $output_pins++ -- * Advanced topics+ -- $advanced_topics+ , TutorialEnv+ , TutorialReaderGpioIO++ -- * Copyright+ -- $copyright+ ) where++import Control.Concurrent (threadDelay)+import Control.Monad (forM_)+import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks)+import qualified Data.ByteString as BS (readFile, writeFile)++import System.GPIO.Monad+ (MonadGpio(..), Pin(..), PinCapabilities(..), PinInputMode(..),+ PinOutputMode(..), PinActiveLevel(..), PinDirection(..),+ PinValue(..), PinInterruptMode(..), SomeGpioException, InputPin,+ OutputPin, InterruptPin, withPin, withInputPin, readInputPin,+ withOutputPin, readOutputPin, writeOutputPin, toggleOutputPin,+ withInterruptPin, readInterruptPin, pollInterruptPin,+ pollInterruptPinTimeout, getInterruptPinInterruptMode,+ setInterruptPinInterruptMode)+import System.GPIO.Linux.Sysfs.Monad (SysfsGpioT(..))+import System.GPIO.Linux.Sysfs.Mock+ (MockGpioChip(..), MockPinState(..), SysfsMockT, SysfsGpioMock, SysfsGpioMockIO,+ defaultMockPinState, initialMockWorld, evalSysfsGpioMockIO, evalSysfsMockT)+import System.GPIO.Linux.Sysfs.Types (SysfsException(..))++-- $setup+-- >>> :set -XFlexibleContexts+-- >>> import System.GPIO.Monad++{- $introduction++The @hpio@ package is a collection of monads for writing GPIO programs+in Haskell.++For each supported GPIO platform, @hpio@ provides two contexts for+writing GPIO programs: a cross-platform domain-specific language+(DSL), and a platform-specific DSL. Programs written in the+cross-platform DSL will run on any supported platform, but as the+cross-platform DSL must take a "least-common denominator" approach,+cross-platform programs may not be capable of taking advantage of all+of the features of a particular GPIO platform. On the other hand,+programs written for a platform-specific DSL can use all of those+platform-specific features, but will not work on other GPIO platforms.++Primarily, this tutorial focuses on the cross-platform DSL.++== Requirements++Though Haskell is a much more capable programming language than, say,+<http://wiring.org.co Wiring>, this power comes with a few trade-offs.+Whereas a program written in Wiring (or even C) can run directly on a+low-cost microcontroller, a program written in Haskell cannot.+Therefore, @hpio@ is intended for use with more powerful GPIO-capable+platforms, such as the <https://www.raspberrypi.org Raspberry Pi platform>,+or the <http://beagleboard.org Beagle platform>, which+marry a 32- or 64-bit CPU core with GPIO functionality.++-}++{- $pin++== GPIO++/General-purpose input\/output/. A GPIO /pin/ is a user-programmable,+serial (i.e., a single-bit wide) interface from the system to an+external device or circuit. GPIO pins can usually be configured either+for input (for reading external signals) or for output (for driving+signals to external devices), though sometimes a pin may be hard-wired+to one direction or the other.++Some platforms may reserve one or more GPIO pins for their own use,+e.g., to drive an external storage interface. Typically these pins are+not visible to the user and therefore cannot be programmed by @hpio@,+but you should always consult your hardware documentation to make sure+you don't accidentally use a system-reserved pin.++GPIO pins are often physically expressed on a circuit board as a male+or female <https://www.google.com/#q=gpio+pin+header breakout header>,+which is a bank of pins (male) or sockets (female) for connecting+individual wires or low-density molded connectors. However, on+platforms with a large number of GPIO pins, it is typically the case+that just a handful of pins are accessible via such a header, while+the rest are only accessible via a high-density connector, intended+for use by high-volume system integrators with custom hardware+designs.++== Pin number++GPIO pins are typically identified by their /pin number/.+Unfortunately, it is often the case that the pin number used in the+system's hardware documentation is different than the pin number used+by the software to identify the same pin.++In @hpio@, a pin's number refers to the number used by the system+software to identify the pin. Consult your hardware documentation (or+Google) for the hardware-to-software pin mapping.++@hpio@ uses the 'Pin' type to identify GPIO pins.++-}++{- $pin_value++== Pin (signal) value++In digital design, a pin's /value/ (sometimes called its /signal level/)+is either /high/ or /low/. When we say that a pin's value or+signal level is /high/, we mean the general notion of the pin being+"on" or /active/; and when we say the pin's value or signal level+is /low/, we mean the pin is "off" or /inactive/.++Complicating matters is the concept of /active-low/ logic. Digital+electronic components are built using either positive (/active-high/)+logic, or negative (/active-low/) logic. In active-high logic, a pin+is active when the voltage on the pin is high (relative to ground);+whereas in active-low logic, a pin is active when the voltage on the+pin is low (or grounded).++When designing logic, or programs to interface with logic, it's often+easier to think of a signal as being active or inactive, rather than+worrying about its physical voltage. Therefore, the @hpio@+cross-platform DSL supports, on a pin-by-pin basis, both types of+logic: active-high and active-low. When writing your programs, you can+simply use the values 'High' and 'Low', and then set a per-pin active+level before running your program, depending on whether you're+interfacing with active-high or active-low logic.++In the @hpio@ documentation, and in this tutorial, whenever you see a+reference to a "pin value" or "signal level," unless otherwise noted,+we mean the abstract notion of the pin being "on" or "off,"+independent of the voltage level seen on the physical pin. We refer to+this notion as the pin's /logical value/, as opposed to+its /physical value/.++In @hpio@, the 'PinValue' type represents a pin's value, and+'PinActiveLevel' represents its active-level setting:++-}++{- $pin_direction++== Pin direction and pin input / output modes++We say a pin's /direction/ is either /in/ (for input) or /out/ (for+output). However, not all inputs and outputs are necessarily the same.+On some GPIO platforms, it's possible to configure an input or output+pin in various /modes/ which change the behavior of the pin under+certain conditions.++For example, consider an input pin. If the pin is not connected to a+source, what is its value? If the input pin is in /floating/ mode+(sometimes called /tri-state/ or /high-impedance/ mode), then its+value when disconnected may "float," or vary, from moment to moment.+Perhaps your application can tolerate this indeterminacy, in which+case floating mode is fine, and probably uses less power than other+input modes, to boot. But if your application requires that a+disconnected pin maintain a predictable, constant state, and your GPIO+platform supports it, you can set the input pin's mode to /pull-up/ or+/pull-down/ to give the disconnected pin an always-high or always-low+value, respectively.++Output pin modes are even more complicated due to the fact that+multiple output pins are often connected together to drive a single+input; this is known as /wired-OR/ or /wired-AND/ design, depending on+whether the devices involved use positive or negative logic.++A full discussion of the various input and output modes, and when you+should use them, is outside the scope of this tutorial. We simply+point out here that the @hpio@ cross-platform DSL provides the ability+to set many of these modes on your input and output pins, provided+that your hardware supports them.++For simple needs, the DSL provides default input and output mode+values, which set whatever mode the target platform uses by default.+These are the values we'll use in this tutorial.++In @hpio@, the 'PinDirection' type represents a pin's direction (a+simple "in" or "out"), while the 'PinInputMode' and 'PinOutputMode'+types represent modes for input and output pins, respectively.++-}++{- $pin_interrupt_mode++== Interrupts++In logic programming, it's often useful to block the program's+execution on an input pin until its value changes. Furthermore, you+may want to wait until the signal transitions from low to high (its+/rising edge/), or from high to low (its /falling edge/).++The @hpio@ cross-platform DSL supports this functionality. You can+block the current Haskell thread on a GPIO input pin until a rising+edge, falling edge, or either edge (a /level trigger/), is visible on+the pin -- effectively, a programmable interrupt. Which type event of+triggers the interrupt is determined by the pin's /interrupt mode/.++If you want to mask interrupts for some period of time without needing+to stop and re-start the blocking thread, you can also disable+interrupts on a given pin.++Some pins may not support this functionality, but the cross-platform+DSL provides a mechanism to query a pin to see whether it's supported.++The 'PinInterruptMode' type represents the type of event which+triggers an interrupt.++-}++{- $pin_capabilities++== Pin capabilities++To help you determine which modes a particular pin supports, @hpio@+provides the 'PinCapabilities' type.++-}++{- $interpreters++The @hpio@ cross-platform DSL is defined by the 'MonadGpio' type+class. Each method of the 'MonadGpio' type class describes an action+that can be performed on a GPIO pin (or on the GPIO system as a+whole).++For each supported platform, @hpio@ provides an instance of the+'MonadGpio' type class. The platform-specific instance maps actions in+the cross-platform DSL to actions on that particular GPIO platform.+You can therefore think of each 'MonadGpio' instance as a+platform-specific interpreter for the cross-platform DSL. Each+interpreter provides a "run" action which, given a 'MonadGpio'+program, will execute the program on its GPIO platform.++-}++{- $mock_interpreter++Testing GPIO programs is inconvenient. The target system is often+under-powered compared to our development environment, and may use a+completely different processor architecture and / or operating system (and+cross-compiling Haskell programs is, circa 2016, still somewhat+problematic). It's also not uncommon for our development environments+not to have any GPIO capabilities at all.++For your convenience, @hpio@ provides a reasonably complete, entirely+software-based "mock" GPIO implementation that can run on any system+where Haskell programs can run, irrespective of that system's GPIO+capabilities or operating system. This particular implementation mocks+the Linux @sysfs@ GPIO filesystem and is capable of emulating much of+that platform's functionality.++In this tutorial, we will make use of this mock GPIO implementation in+many of the code examples, meaning that those examples can be run on+any Haskell-capable system. In a few cases, we'll discuss+functionality that the mock implementation does not handle. These+cases will be called out.++To use the mock interpreter, you must supply its mock GPIO state, and+this is a bit complicated, not to mention irrelevant to understanding+how to use the @hpio@ cross-platform DSL. (Using an interpreter for a+real GPIO platform is much simpler.) To avoid getting bogged down in+the details, we'll supply a wrapper, named 'runTutorial', which sets+up a mock GPIO environment with 17 pins and runs a @hpio@ program in+that environment. The first 16 pins, numbered 0-15, are fully-general+pins. Pin 17 is a special-case pin that we'll use to demonstrate+failure modes and other quirks.++(Don't worry about the details of the 'SysfsGpioMockIO' type for the+moment. We'll explain it later. For now, suffice it to say that it's+the type of our @hpio@ programs when run in this particular mock+interpreter.)++__Note__: in our examples, each time we use 'runTutorial' we are+creating a new mock environment from scratch, so any changes made to+the mock environment are not persistent from one example to the next.++-}++chip0 :: MockGpioChip+chip0 = MockGpioChip "chip0" 0 (replicate 16 defaultMockPinState)+chip1 :: MockGpioChip+chip1 = MockGpioChip "chip1" 16 [defaultMockPinState {_direction = In, _userVisibleDirection = False, _value = High, _edge = Nothing}]++-- | Run a @hpio@ program on a mock system with 17 GPIO pins.+runTutorial :: SysfsGpioMockIO a -> IO a+runTutorial program =+ evalSysfsGpioMockIO program initialMockWorld [chip0, chip1]++{- $basic_pin_operations++== Which pins are available?++To get the list of all pins available on the system, use the 'pins' command:++>>> runTutorial pins+[Pin 0,Pin 1,Pin 2,Pin 3,Pin 4,Pin 5,Pin 6,Pin 7,Pin 8,Pin 9,Pin 10,Pin 11,Pin 12,Pin 13,Pin 14,Pin 15,Pin 16]++== Querying a pin's capabilities++To see which modes a pin supports, use the 'pinCapabilities' command:++>>> runTutorial $ pinCapabilities (Pin 1)+PinCapabilities {_inputModes = fromList [InputDefault], _outputModes = fromList [OutputDefault], _interrupts = True}++>>> runTutorial $ pinCapabilities (Pin 16)+PinCapabilities {_inputModes = fromList [], _outputModes = fromList [], _interrupts = False}++Here we can see that 'Pin' @1@ can support both input and output --+though not any specific input or output modes, only the defaults --+and also interrupts. 'Pin' @16@, on the other hand, is effectively+useless, as it's capable of neither input nor output. ('Pin' @16@ is+pathalogical, and you wouldn't expect to see a pin like this on an+actual system.)++== Pin resource management++Before you can operate on a GPIO pin, you must signal your intention+to the system by /opening/ that pin. Opening the pin returns a+/handle/, which you then use to operate on the pin. Then, when you're+finished with the pin, you should allow the system to clean up any+pin-related resources by /closing/ the pin.++Opening and closing a pin are performed by the 'openPin' and+'closePin' DSL actions, respectively:++>>> :{+runTutorial $+ do h <- openPin (Pin 5)+ liftIO $ putStrLn "Opened pin 5"+ closePin h+ liftIO $ putStrLn "Closed pin 5"+:}+Opened pin 5+Closed pin 5++(Note that, because our interpreter is an instance of 'MonadIO', we+can interleave 'IO' actions into our GPIO computations.)++As with file handles, when an exception occurs in a computation, we+should clean up any open pin handles. We could wrap each 'openPin' /+'closePin' pair with 'Control.Monad.Catch.bracket', or we could just+use the provided 'withPin' wrapper, which does this for us:++>>> :{+runTutorial $+ withPin (Pin 5) $ \h ->+ do liftIO $ putStrLn "Opened pin 5"+ fail "Oops"+:}+Opened pin 5+*** Exception: user error (Oops)++Using 'withPin' is good hygiene, so we'll use it throughout this+tutorial.++You can, of course, nest uses of 'withPin':++>>> :{+runTutorial $+ do withPin (Pin 5) $ \h1 ->+ do liftIO $ putStrLn "Opened pin 5"+ withPin (Pin 6) $ \h2 ->+ liftIO $ putStrLn "Opened pin 6"+ liftIO $ putStrLn "Closed pin 6"+ liftIO $ putStrLn "Closed pin 5"+:}+Opened pin 5+Opened pin 6+Closed pin 6+Closed pin 5++== Pin configuration++Every pin has an active level, which we can query using+'getPinActiveLevel':++>>> runTutorial $ withPin (Pin 8) getPinActiveLevel+ActiveHigh++You can change it using 'setPinActiveLevel':++>>> :{+runTutorial $+ withPin (Pin 5) $ \h ->+ do setPinActiveLevel h ActiveLow+ getPinActiveLevel h+:}+ActiveLow++or toggle it using 'togglePinActiveLevel':++>>> runTutorial $ withPin (Pin 8) togglePinActiveLevel+ActiveLow++You can get a pin's current direction using 'getPinDirection':++>>> runTutorial $ withPin (Pin 10) getPinDirection+Out++>>> runTutorial $ withPin (Pin 16) getPinDirection -- Pin 16's direction is not settable+*** Exception: NoDirectionAttribute (Pin 16)++If 'getPinDirection' fails, as it does for 'Pin' @16@ in our example,+then the pin's direction is not queryable in a cross-platform way, in+which case you'll need another (platform-specific) method for+determining its hard-wired direction.++To configure a pin for input or output, we must specify not only its+direction, but also its input / output mode, as discussed earlier.+Therefore, there is no @setPinDirection@ action. Instead, you set the+pin's direction and mode simultaneously using the 'setPinInputMode'+or 'setPinOutputMode' actions:++>>> :{+runTutorial $+ withPin (Pin 5) $ \h ->+ do setPinInputMode h InputDefault+ getPinDirection h+:}+In++>>> :{+runTutorial $+ withPin (Pin 5) $ \h ->+ do setPinOutputMode h OutputDefault Low+ getPinDirection h+:}+Out++Note that when we configure a pin for output, we must also supply an+initial output value for the pin. (This value is relative to the pin's+active level, i.e., it is a logical value.)++If we want to know more about the pin's input or output configuration+than just its direction, we can query its input or output mode:++>>> :{+runTutorial $+ withPin (Pin 5) $ \h ->+ do setPinInputMode h InputDefault+ getPinInputMode h+:}+InputDefault++>>> :{+runTutorial $+ withPin (Pin 7) $ \h ->+ do setPinOutputMode h OutputDefault Low+ getPinOutputMode h+:}+OutputDefault++It's an error to query a pin's input mode when the pin is configured+for output, and vice versa:++ >>> :{+ runTutorial $+ withPin (Pin 5) $ \h ->+ do setPinInputMode h InputDefault+ getPinOutputMode h+ :}+ *** Exception: InvalidOperation (Pin 5)++ >>> :{+ runTutorial $+ withPin (Pin 7) $ \h ->+ do setPinOutputMode h OutputDefault Low+ getPinInputMode h+ :}+ *** Exception: InvalidOperation (Pin 7)++If we attempt to use a mode that the pin doesn't support, we get an+error:++>>> :{+runTutorial $+ withPin (Pin 5) $ \h ->+ setPinInputMode h InputPullDown+:}+*** Exception: UnsupportedInputMode InputPullDown (Pin 5)++>>> :{+runTutorial $+ withPin (Pin 5) $ \h ->+ setPinOutputMode h OutputOpenSourcePullDown Low+:}+*** Exception: UnsupportedOutputMode OutputOpenSourcePullDown (Pin 5)++Also, it's obviously an error to try to set the direction of a pin+whose direction is not settable:++>>> :{+-- Pin 16's direction is not settable+runTutorial $+ withPin (Pin 16) $ \h ->+ setPinInputMode h InputDefault+:}+*** Exception: NoDirectionAttribute (Pin 16)++The 'NoDirectionAttribute' exception value refers to the Linux @sysfs@+GPIO per-pin @direction@ attribute, which is used to configure the+pin's direction. Exception types in @hpio@ are platform-specific -- in+this case, specific to Linux @sysfs@ GPIO, as we're using the mock+@sysfs@ GPIO interpreter -- and vary based on which particular+interpreter you're using, but all @hpio@ exception types are instances+of the 'SomeGpioException' type class.++Finally, some pins, /when configured for input/, may support edge- or+level-triggered interrupts. As with the pin's direction, you can+discover whether a pin supports this functionality by asking for its+interrupt mode via the 'getPinInterruptMode' action:++ >>> :{+ runTutorial $+ withPin (Pin 5) $ \h ->+ do setPinInputMode h InputDefault+ getPinInterruptMode h+ :}+ Disabled++>>> runTutorial $ withPin (Pin 16) $ getPinInterruptMode+*** Exception: NoEdgeAttribute (Pin 16)++In our example, 'Pin' @16@ does not support interrupts, so+'getPinInterruptMode' throws an exception.++If the pin supports interrupts, you can change its interrupt mode+using 'setPinInterruptMode'. In this example, we configure 'Pin' @5@+for level-triggered interrupts. Note that we must configure the pin+for input before we do so:++ >>> :{+ runTutorial $+ withPin (Pin 5) $ \h ->+ do setPinInputMode h InputDefault+ setPinInterruptMode h Level+ getPinInterruptMode h+ :}+ Level++If the pin does not support interrupts, or if the pin is configured+for output, it is an error to attempt to set its interrupt mode:++ >>> :{+ -- Here we have tried to set an output pin's interrupt mode+ runTutorial $+ withPin (Pin 5) $ \h ->+ do setPinOutputMode h OutputDefault Low+ setPinInterruptMode h Level+ getPinInterruptMode h+ :}+ *** Exception: InvalidOperation (Pin 5)++ >>> :{+ -- Pin 16 does not support interrupts+ runTutorial $+ withPin (Pin 16) $ \h ->+ do setPinInterruptMode h Level+ getPinInterruptMode h+ :}+ *** Exception: NoEdgeAttribute (Pin 16)++Note that the exception value thrown in each case is different, to+better help you identify what you did wrong.++See below for examples of how to make use of pin interrupts and a+pin's interrupt mode.++-}++{- $reading_and_writing++The core operation of GPIO is, of course, reading and writing pin values.++To read a pin's value and return that value immediately, without+blocking the current thread, use the 'readPin' action:++ >>> :{+ -- Pin 16 is hard-wired for input.+ -- Its physical signal level is 'High'.+ runTutorial $ withPin (Pin 16) readPin+ :}+ High++ >>> :{+ -- Pin 9's initial direction is 'Out'.+ -- Its initial physical signal level is 'Low'.+ runTutorial $ withPin (Pin 9) readPin+ :}+ Low++Note that we can use 'readPin' on a pin regardless of its direction or+input / output mode.++The value returned by 'readPin' is relative to the pin's current+active level. Using the same pins as the previous two examples, but+this time changing their active levels before reading them, we get:++ >>> :{+ runTutorial $+ withPin (Pin 16) $ \h ->+ do setPinActiveLevel h ActiveLow+ readPin h+ :}+ Low++ >>> :{+ runTutorial $+ withPin (Pin 9) $ \h ->+ do setPinActiveLevel h ActiveLow+ readPin h+ :}+ High++When a pin is configured for output, we can set its value using+'writePin':++ >>> :{+ runTutorial $+ withPin (Pin 9) $ \h ->+ do setPinOutputMode h OutputDefault Low+ writePin h High+ readPin h+ :}+ High++It is an error to attempt to set the value of a pin that is configured+for input:++ >>> :{+ runTutorial $+ withPin (Pin 9) $ \h ->+ do setPinInputMode h InputDefault+ writePin h High+ readPin h+ :}+ *** Exception: PermissionDenied (Pin 9)++We can also toggle an output pin's value using 'togglePin', which+returns the new value:++ >>> :{+ runTutorial $+ withPin (Pin 9) $ \h ->+ do setPinOutputMode h OutputDefault Low+ v1 <- togglePin h+ v2 <- togglePin h+ return (v1,v2)+ :}+ (High,Low)++The value we write on an output pin is relative to its current active+level; e.g., if the output pin's active level is 'Low' and we write a+'High' value, then the /physical/ signal level that the system drives+on that pin is /low/. In the mock GPIO system there is no physical+signal level, per se, but the mock interpreter does keep track of the+"actual" value:++ >>> :{+ runTutorial $+ withPin (Pin 9) $ \h ->+ do setPinActiveLevel h ActiveLow+ setPinOutputMode h OutputDefault High+ v1 <- readPin h+ setPinActiveLevel h ActiveHigh+ v2 <- readPin h+ return (v1,v2)+ :}+ (High,Low)++ >>> :{+ runTutorial $+ withPin (Pin 9) $ \h ->+ do setPinActiveLevel h ActiveLow+ setPinOutputMode h OutputDefault High+ v1 <- togglePin h+ setPinActiveLevel h ActiveHigh+ v2 <- togglePin h+ return (v1,v2)+ :}+ (Low,Low)++(Note that in a real circuit, the value returned by 'readPin' or+'togglePin' on an output pin may be different than the value your+program last wrote to it, depending on the pin's output mode, what+other elements are attached to the pin, etc. A discussion of these+factors is outside the scope of this tutorial.)++== Waiting for interrupts++As described above, 'readPin' reads a pin's current value and returns+that value immediately. 'pollPin' and 'pollPinTimeout', like+'readPin', also return a given input pin's value. However, unlike+'readPin', these actions do not return the value immediately, but+instead block the current thread until a particular event occurs.+Given a handle to an input pin, 'pollPin' will block the current+thread on that pin's value until an event corresponding to the the+pin's interrupt mode event occurs, at which point 'pollPin' unblocks+and returns the value that triggered the event. 'pollPinTimeout' is+like 'pollPin', except that it also takes a timeout argument and+returns the pin's value wrapped in a 'Just' value. If the timeout+expires before the event occurs, 'pollPinTimeout' returns 'Nothing'.++The current implementation of the mock @sysfs@ GPIO interpreter does+not support interrupts, so we do not provide a runnable example in+this tutorial. However, here is an example from an actual Linux system+which demonstrates the use of 'pollPinTimeout' (a+<https://github.com/dhess/gpio/blob/master/examples/Gpio.hs similar program>+is included in @hpio@'s source distribution):++> -- interrupt.hs+>+> import Control.Concurrent (threadDelay)+> import Control.Concurrent.Async (concurrently)+> import Control.Monad (forever, void)+> import Control.Monad.Catch (MonadMask)+> import Control.Monad.IO.Class (MonadIO, liftIO)+> import System.GPIO.Linux.Sysfs (runSysfsGpioIO)+> import System.GPIO.Monad+> import System.GPIO.Types+>+> -- | Given a pin, an interrupt mode, and a timeout (in microseconds),+> -- configure the pin for input, then repeatedly wait for either the+> -- given event, or a timeout.+> pollInput :: (MonadMask m, MonadIO m, MonadGpio h m) => Pin -> PinInterruptMode -> Int -> m ()+> pollInput p mode to =+> withPin p $ \h ->+> do setPinInputMode h InputDefault+> setPinInterruptMode h mode+> forever $+> do result <- pollPinTimeout h to+> case result of+> Nothing -> output ("pollInput timed out after " ++ show to ++ " microseconds")+> Just v -> output ("Input: " ++ show v)+>+> -- | Given a pin and a 'delay' (in microseconds), configure the pin for output and+> -- repeatedly toggle its value, pausing for 'delay' microseconds inbetween+> -- successive toggles.+> driveOutput :: (MonadMask m, MonadIO m, MonadGpio h m) => Pin -> Int -> m ()+> driveOutput p delay =+> withPin p $ \h ->+> do setPinOutputMode h OutputMode Low+> forever $+> do liftIO $ threadDelay delay+> v <- togglePin h+> output ("Output: " ++ show v)+>+>++Given these two looping actions, we can launch two threads, one for+each loop, to drive the input pin from the output pin, assuming the+two pins are connected. For example, to wait for the signal's rising+edge using @gpio47@ for input and @gpio48@ for output with a 1-second+read timeout and a 1/4-second delay between output value toggles:++> -- interrupt.hs+> main =+> void $+> concurrently+> (void $ runSysfsGpioIO $ pollInput (Pin 47) RisingEdge 1000000)+> (runSysfsGpioIO $ driveOutput (Pin 48) 250000)++> $ ./interrupt+> Output: High+> Input: High+> Output: Low+> Output: High+> Input: High+> Output: Low+> Output: High+> Input: High+> Output: Low+> Output: High+> Input: High+> ^C $++Note that the @Input@ lines only appear when the output signal goes+from 'Low' to 'High', as @pollInput@ is waiting for 'RisingEdge' events+on the input pin.++If we now flip the read timeout and toggle delay values, we can see+that @pollInput@ times out every 1/4-second until the rising edge+occurs again:++> -- interrupt.hs+> main =+> void $+> concurrently+> (void $ runSysfsGpioIO $ pollInput (Pin 47) RisingEdge 250000)+> (runSysfsGpioIO $ driveOutput (Pin 48) 1000000)++> $ ./interrupt+> pollInput timed out after 250000 microseconds+> pollInput timed out after 250000 microseconds+> pollInput timed out after 250000 microseconds+> Output: High+> Input: High+> pollInput timed out after 250000 microseconds+> pollInput timed out after 250000 microseconds+> pollInput timed out after 250000 microseconds+> Output: Low+> pollInput timed out after 250000 microseconds+> pollInput timed out after 250000 microseconds+> pollInput timed out after 250000 microseconds+> pollInput timed out after 250000 microseconds+> Output: High+> Input: High+> pollInput timed out after 250000 microseconds+> pollInput timed out after 250000 microseconds+> pollInput timed out after 250000 microseconds+> Output: Low+> pollInput timed out after 250000 microseconds+> pollInput timed out after 250000 microseconds+> pollInput timed out after 250000 microseconds+> pollInput timed out after 250000 microseconds+> Output: High+> Input: High+> pollInput timed out after 250000 microseconds+> ^C $++Because they block the current thread, in order to use 'pollPin' and+'pollPinTimeout', you must compile your program such that the Haskell+runtime supports multiple threads. On GHC, use the @-threaded@+compile-time flag. Other Haskell compilers have not been tested with+@hpio@, so we cannot provide guidance for them; consult your+compiler's documentation. Also, if you're using a compiler other than+GHC on Linux, see the documentation for the+'System.GPIO.Linux.Sysfs.IO.SysfsIOT' monad transformer for details on+how it uses the C FFI, and its implications for multi-threading.++-}++{- $pin_types++You may have noticed that, while describing the various DSL actions+above, we spent almost as much time talking about error conditions as+we did properly-functioning code. Primarily, this is due to the low-level nature+of native GPIO APIs.++Native GPIO APIs, as a rule, provide more or less the same interface+for all GPIO pins, regardless of their actual capabilities or+configuration. For example, a pin configured for input is typically+represented by the system as the same type as a pin configured for+output, even though the set of actions that can legally be performed+on each pin is different.++One advantage of this approach is that it is quite flexible. It is,+for example, possible to re-configure a given pin "on the fly" for+input, output, interrupts, etc. However, a drawback of this approach+is that it's easy to make a mistake, e.g., by waiting for interrupts+on a pin that has been configured for output (an operation which, on+Linux, at least, will not raise an error but will block forever).++The primary goal of the @hpio@ cross-platform DSL is to make available+to the Haskell programmer as much of the low-level capabilities of a+typical GPIO platform as possible. As such, it retains both the+flexibility of this one-pin-fits-all approach, and its disadvantages.+The disadvantages are apparent by the number of ways you can cause an+exception by performing an invalid operation on a pin.++By trading some of that flexibility for more restricted types, we can+make GPIO programming safer. The @hpio@ cross-platform DSL therefore+provides 3 additional types for representing pins in a particular+configuration state (input, interrupt-capable input, or output), and+then defines the subset of GPIO actions that can safely be performed+on a pin in that state. This makes it possible to write GPIO programs+which, given a particular pin type, cannot perform an illegal+action on that pin.++The 3 safer pin types are 'InputPin', 'OutputPin', and 'InterruptPin'.+The constructors for these types are not exported. You can only create+instances of these types by calling their corresponding @with*@+action. Each type's @with*@ action attempts to configure the pin as+requested; if it cannot, the @with*@ action throws an exception, but+if it can, you can use the returned instance safely.++(Note: all of these safer pin types support actions which query or+change their active level, but as these actions are effectively+identical to the more general 'getPinActiveLevel' and+'setPinActiveLevel' actions, examples of their use are not given here.)++-}++{- $input_pins++== Input pins++Input pins can be read with a non-blocking read via the 'readInputPin'+action:++>>> :{+runTutorial $+ withInputPin (Pin 2) InputDefault Nothing $ \h ->+ readInputPin h+:}+Low++-}++{- $interrupt_pins++== Interrupt pins++Interrupt pins can be read with a non-blocking read via the+'readInterruptPin' action:++>>> :{+runTutorial $+ withInterruptPin (Pin 2) InputDefault Level Nothing $ \h ->+ readInterruptPin h+:}+Low++They also, of course, support interrupts (blocking reads). Because the+mock interpreter cannot emulate interrupts, no working examples are+given here, but see the 'pollInterruptPin' and+'pollInterruptPinTimeout' actions for details.++Changing an interrupt pin's interrupt mode is generally a safe+operation, so the DSL provides the 'getInterruptPinInterruptMode' and+'setInterruptPinInterruptMode' actions:++>>> :{+runTutorial $+ withInterruptPin (Pin 2) InputDefault RisingEdge Nothing $ \h ->+ do m1 <- getInterruptPinInterruptMode h+ setInterruptPinInterruptMode h FallingEdge+ m2 <- getInterruptPinInterruptMode h+ return (m1,m2)+:}+(RisingEdge,FallingEdge)++-}++{- $output_pins++== Output pins++Output pins can be both read ('readOutputPin') and written+('writeOutputPin'):++>>> :{+runTutorial $+ withOutputPin (Pin 8) OutputDefault Nothing Low $ \h ->+ do v1 <- readOutputPin h+ writeOutputPin h High+ v2 <- readOutputPin h+ return (v1,v2)+:}+(Low,High)++The pin's value can also be toggled via 'toggleOutputPin':++>>> :{+runTutorial $+ withOutputPin (Pin 8) OutputDefault Nothing Low $ \h ->+ toggleOutputPin h+ :}+High++-}++{- $advanced_topics++== The Linux @sysfs@ GPIO interpreter++Using the Linux @sysfs@ GPIO interpreter is complicated by the fact+that it supports both actual Linux systems, and the mock environment+that we've used throughout most of this tutorial.++Strictly speaking, you don't need to understand how the @sysfs@ GPIO+interpreter implemented, but understanding it does help motivate why+using it seems a bit convoluted.++In Linux @sysfs@ GPIO, userspace GPIO operations are performed on+virtual files in the @sysfs@ filesystem. See the+<https://www.kernel.org/doc/Documentation/gpio/sysfs.txt Linux kernel documentation>+for details, but in a nutshell:++* Pins are /exported/ (akin to opening a file) by writing their pin+number to the @\/sys\/class\/gpio\/export@ file.++* Once a pin is exported, the Linux kernel creates a subdirectory for+that pin number (e.g., @\/sys\/class\/gpio\/gpio7@), along with several+pseudo-files, called /attributes/, for controlling the pin's+direction, reading and writing its pin value, etc.++* Pins are /unexported/ (akin to closing a file) by writing their pin+number to the @\/sys\/class\/gpio\/unexport@ file. When the pin is+unexported, the kernel removes the pin's @sysfs@ subdirectory.++The @hpio@ interpreter for the Linux @sysfs@ GPIO system translates+actions in the cross-platform DSL to @sysfs@ filesystem operations.+The most straightforward way to implement this interpreter is to use+filesystem actions such as 'BS.readFile' and 'BS.writeFile' directly.+However, by adding a level of abstraction at the filesystem layer, we+can substitute a @sysfs@ filesystem emulator for the real thing, and+the interpreter's none the wiser. Because we're only implementing the+subset of filesystem functionality required by the Linux @sysfs@ GPIO+interpreter (and certainly not an entire real filesystem!), there are+only a handful of actions we need to emulate.++So that is the approach used by @hpio@'s @sysfs@ interprefer. It+breaks the Linux @sysfs@ GPIO interpreter into two pieces: a+high-level piece which maps cross-platform GPIO operations to abstract+filesystem actions, and a low-level piece which implements those+filesystem actions. It then provides two low-level implementations:+one which maps the abstract filesystem actions onto real filesystem+operations, and one which implements a subset of the @sysfs@+filesystem as an in-memory mock filesystem for emulating the Linux+kernel's @sysfs@ GPIO behavior.++To use this implementation, you don't need to worry about these+details; you just need to know how to compose the two interpreters. If+you want to run real GPIO programs on a real Linux GPIO-capable+system, the composition is relatively straightforward. Assuming that+@program@ is your program:++> runSysfsIOT $ runSysfsGpioT program++Here the 'System.GPIO.Linux.Sysfs.runSysfsGpioT' interpreter+translates GPIO actions in @program@ to abstract @sysfs@ filesystem+operations, and the 'System.GPIO.Linux.Sysfs.runSysfsIOT' interpreter+translates abstract @sysfs@ filesystem operations to their native+filesystem equivalents.++(Note that if @program@ runs directly in 'IO' and not in a transformer+stack, then you can use the 'System.GPIO.Linux.Sysfs.runSysfsGpioIO'+action, which conveniently composes these two interpreters for you.)++== @mtl@ compatibility and use with transformer stacks++Most of the examples shown up to this point in the tutorial have run+directly on top of the 'IO' monad (via 'MonadIO'). However, in the+event that you want to integrate GPIO computations into more+complicated monad transformer stacks, @hpio@ has you covered!++Each @hpio@ interpreter is implemented as a monad transformer, and+each is also an instance of the monad type classes defined in the+<https://hackage.haskell.org/package/mtl mtl> package, so long as its+implementation satisfies the laws of that particular @mtl@ type class.+This makes it easy to integrate @hpio@ interpreters into @mtl@-style+monad transformer stacks.++Additionally, the 'MonadGpio' type class provides instances of itself+for all the @mtl@ monad type classes for which it can satisfy the+laws, meaning that you don't need to 'lift' 'MonadGpio' operations out+of these monads manually.++Here's an example of using a 'MonadGpio' program with the reader+monad and the mock @sysfs@ GPIO interpreter. (A+<https://github.com/dhess/gpio/blob/master/examples/GpioReader.hs more sophisticated example>+of using 'MonadGpio' with a reader transformer+stack and a real (as opposed to mock) GPIO platform is provided in the+@hpio@ source distribution.)++First, let's define the reader environment and give our transformer+stack a type alias:++> data TutorialEnv =+> TutorialEnv {_pin :: Pin+> ,_initialValue :: PinValue+> ,_delay :: Int+> ,_iterations :: Int}+>+> -- | Our transformer stack:+> -- * A reader monad.+> -- * The Linux @sysfs@ GPIO interpreter+> -- * The (mock) Linux @sysfs@ back-end.+> -- * 'IO'+> type TutorialReaderGpioIO a = ReaderT TutorialEnv (SysfsGpioT (SysfsMockT IO)) a++Next, let's define the interpreter for our stack. Up to this point,+we've used 'runTutorial' as our interpreter, and it has handled all+the nitty-gritty details of composing the @sysfs@ GPIO+sub-interpreters and configuring the mock GPIO environment. Now,+however, it's time to expose those layers and talk about them in+detail, as that's where most of the complexity comes when using+transformer stacks.++> -- | Mock GPIO chips+> chip0 :: MockGpioChip+> chip0 = MockGpioChip "chip0" 0 (replicate 16 defaultMockPinState)+> chip1 :: MockGpioChip+> chip1 = MockGpioChip "chip1" 16 [defaultMockPinState {_direction = In, _userVisibleDirection = False, _value = High, _edge = Nothing}]+>+> -- | The interpreter for our transformer stack.+> runTutorialReaderGpioIO :: TutorialReaderGpioIO a -> TutorialEnv -> IO a+> runTutorialReaderGpioIO program config =+> evalSysfsMockT+> (runSysfsGpioT $ runReaderT program config)+> initialMockWorld+> [chip0, chip1]++Don't worry too much about the 'MockGpioChip' definitions or the+'initialMockWorld' ; those exist only to set up the mock GPIO+environment so that we can run some examples in this tutorial. In a+real Linux GPIO environment, the definition for the interpreter would+be quite a bit simpler, as we wouldn't need to supply this mock+environment. An analogous transformer stack for a real Linux @sysfs@+GPIO system would look something like this:++> -- | Our 'IO' transformer stack:+> -- * A reader monad.+> -- * The Linux @sysfs@ GPIO interpreter+> -- * The (real) Linux @sysfs@ back-end.+> -- * 'IO'+> type TutorialReaderGpioIO a = ReaderT TutorialEnv (SysfsGpioT (SysfsIOT IO)) a+>+> -- | The interpreter for our IO transformer stack.+> runTutorialReaderGpioIO :: TutorialReaderGpioIO a -> Config -> IO a+> runTutorialReaderGpioIO program config = runSysfsIOT $ runSysfsGpioT $ runReaderT program config++(The earlier cited+<https://github.com/dhess/gpio/blob/master/examples/GpioReader.hs example program>+uses this very stack, albeit with a different reader environment.)++The part that's the same in both the mock transformer stack and the+"real" transformer stack is this bit:++> runSysfsGpioT $ runReaderT program config++Here we see 2 layers of the transformer stack: at the core is the+'ReaderT' transformer, which we execute via the 'runReaderT'+"interpreter." This layer provides us with the ability to use reader+monad actions such as 'asks' inside our @program@.++The next layer up is the 'SysfsGpioT' transformer, which we execute+via the 'runSysfsGpioT' interpreter. This layer makes the @hpio@+cross-platform DSL actions available to our @program@ -- actions such+as 'readPin' and 'writePin'.++However, as explained earlier in the tutorial, the 'SysfsGpioT'+transformer is only one half of the @sysfs@ GPIO story. The+'runSysfsGpioT' interpreter translates GPIO actions such as 'readPin'+to Linux @sysfs@ GPIO operations, but it does not provide the+/implementation/ of those @sysfs@ GPIO operations: it depends on yet+another layer of the transformer stack to provide that functionality.++This is where 'SysfsMockT' and 'evalSysfsMockT' come in (or, in the+case of a "real" GPIO program that runs on an actual Linux system,+'System.GPIO.Linux.Sysfs.SyfsIOT' and+'System.GPIO.Linux.Sysfs.runSysfsIOT'). The 'SysfsMockT' transformer+maps @sysfs@ GPIO operations in the 'runSysfsGpioT' interpreter onto+mock @sysfs@ filesystem actions; and the 'evalSysfsMockT' interpreter+provides the in-memory implementation of those mock @sysfs@ filesystem+actions.++Likewise, as you can probably guess from the definition of our "real"+GPIO transformer stack, the 'System.GPIO.Linux.Sysfs.SyfsIOT'+transformer and its 'System.GPIO.Linux.Sysfs.runSysfsIOT' interpreter+map abstract @sysfs@ GPIO operations in the 'runSysfsGpioT'+interpreter onto /actual/ @sysfs@ filesystem actions using Haskell's+standard filesystem actions ('BS.readFile', 'BS.writeFile', etc.)++(If you're curious about the interface between the two @sysfs@+interpreter layers, see the 'System.GPIO.Linux.Sysfs.Monad.MonadSysfs'+type class. You can even use it directly, if you want to implement+your own @sysfs@-specific GPIO DSL.)++Returning to our mock transformer stack, the 'SysfsMockT' transformer+is just a @newtype@ wrapper around the+'Control.Monad.State.Strict.StateT' transformer. The state that the+'SysfsMockT' transformer provides to its interpreter is the state of+all mock pins defined by the mock GPIO system, and the state of the+in-memory mock filesystem (the directory structure, the contents of+the various files, etc.).++For testing purposes, it's often useful to retrieve the final mock+state along with the final result of a mock @hpio@ computation, so+just as 'Control.Monad.State.Strict.StateT' does, the 'SysfsMockT'+transformer provides three different interpreters. Which interpreter+you choose depends on whether you want the final mock state of the+computation, the final result of the computation, or a tuple+containing the pair of them. For our purposes in this tutorial, we+only want the final result of the computation, so we use the+'evalSysfsMockT' interpreter here.++The mock state of the mock @sysfs@ interpreter is completely+configurable. We won't go into the details in this tutorial, but in a+nutshell, you provide the mock interpreter a list of mock pins along+with their initial state; and the initial state of the mock @sysfs@+GPIO filesystem. The @[chip0, chip1]@ and 'initialMockWorld' values+passed to the 'evalSysfsMockT' interpreter provide the initial state+that we'll use in our transformer stack examples. (These parameters+are not needed for the "real" @sysfs@ interpreter, of course, since+the actual hardware and the Linux kernel determine the visible GPIO+state on a real system.)++By composing the 'runSysfsGpioT' and 'evalSysfsMockT' interpreters+(or, in the case of a real Linux system, the 'runSysfsGpioT' and+'System.GPIO.Linux.Sysfs.runSysfsIOT' interpreters), we create a+complete @hpio@ cross-platform DSL interpreter.++The final, outer-most layer of our transformer stack is 'IO'. You may+be wondering why, as we're using the mock @sysfs@ interpreter here+(which does not perform any 'IO' actions), we need the 'IO' monad. As+it turns out, we do not! Both the 'SysfsMockT' transformer and the+'SysfsGpioT' transformer are pure, and neither requires the 'IO' monad+in order to function.++They /do/, however, need to be stacked on top of a monad which is an+instance of 'MonadThrow'. Additionally, 'SysfsGpioT' requires its+inner monad to be an instance of 'MonadCatch'. GPIO computations --+even mock ones -- can throw exceptions, and we need a way to express+them "out of band." @hpio@ uses the excellent+<https://hackage.haskell.org/package/exceptions exceptions> package,+which provides the 'MonadThrow' and 'MonadCatch' abstractions and+makes it possible for the mock @sysfs@ GPIO interpreter to run in a+pure environment, without 'IO', so long as the inner monad is an+instance of both 'MonadThrow' and 'MonadCatch'.++In fact, the @exceptions@ package provides the+'Control.Monad.Catch.Pure.Catch' monad, which satisfies both of those+constraints, and @hpio@'s mock @sysfs@ implementation provides a+convenient type alias for an interpreter which runs @hpio@+computations in a pure mock GPIO environment, using+'Control.Monad.Catch.Pure.Catch' as the outer-most monad, rather than+'IO'. That interpreter expresses GPIO errors as 'Left' values instead+of throwing exceptions. See 'SysfsGpioMock' and its interpreters for+details.++However, in this tutorial, we're only using the mock @sysfs@ GPIO+interpreter out of necessity, and we prefer to keep the examples as+close to "real world" behavior as we can. Therefore, we use 'IO' here+and express errors in GPIO computations as actual thrown exceptions,+rather than pure 'Left' values.++== A reader monad example++Now that we've defined (and explained to death) an example transformer+stack, let's put it to use. We define the following trivial program,+which runs in our transformer stack and makes use of the reader monad+context to retrieve its configuration:++>>> :{+let toggleOutput :: (MonadMask m, MonadIO m, MonadGpio h m, MonadReader TutorialEnv m) => m ()+ toggleOutput =+ do p <- asks _pin+ delay <- asks _delay+ iv <- asks _initialValue+ it <- asks _iterations+ withPin p $ \h ->+ do setPinOutputMode h OutputDefault iv+ forM_ [1..it] $ const $+ do liftIO $ threadDelay delay+ v <- togglePin h+ liftIO $ putStrLn ("Output: " ++ show v)+:}++>>> runTutorialReaderGpioIO toggleOutput (TutorialEnv (Pin 4) High 100000 5)+Output: Low+Output: High+Output: Low+Output: High+Output: Low++>>> runTutorialReaderGpioIO toggleOutput (TutorialEnv (Pin 16) High 100000 5)+*** Exception: NoDirectionAttribute (Pin 16)++>>> runTutorialReaderGpioIO toggleOutput (TutorialEnv (Pin 99) High 100000 5)+*** Exception: InvalidPin (Pin 99)++More important than what this program does, is its type signature. It+runs in a monad @m@ and returns a void result, but note the following+about monad @m@:++* It must be an instance of 'MonadMask' because it calls 'withPin'.++* It must be an instance of 'MonadIO' because it calls 'putStrLn'+and 'threadDelay'.++* It must be an instance of 'MonadReader' 'TutorialEnv' because it+uses 'asks' to extract its configuration from a 'TutorialEnv'.++* It must be an instance of 'MonadGpio' because it uses actions from+the @hpio@ cross-platform DSL. (By the way, the @h@ type parameter to+'MonadGpio' represents an implementation-dependent pin handle type.)++Our mock transformer stack satisfies all of these requirements, so+it's capable of running this program. The "real GPIO" transformer+stack we defined earlier is also capable of running this program, and+as future GPIO platforms are added to @hpio@, any of those+interpreters will be able to run this program, as well!++-}++data TutorialEnv =+ TutorialEnv {_pin :: Pin+ ,_initialValue :: PinValue+ ,_delay :: Int+ ,_iterations :: Int}++type TutorialReaderGpioIO a = ReaderT TutorialEnv (SysfsGpioT (SysfsMockT IO)) a++runTutorialReaderGpioIO :: TutorialReaderGpioIO a -> TutorialEnv -> IO a+runTutorialReaderGpioIO program config =+ evalSysfsMockT+ (runSysfsGpioT $ runReaderT program config)+ initialMockWorld+ [chip0, chip1]++{- $copyright++This tutorial is copyright Drew Hess, 2016, and is licensed under the+<http://creativecommons.org/licenses/by/4.0/ Creative Commons Attribution 4.0 International License>.++-}
+ src/System/GPIO/Types.hs view
@@ -0,0 +1,302 @@+{-|+Module : System.GPIO.Types+Description : Basic GPIO types+Copyright : (c) 2016, Drew Hess+License : BSD3+Maintainer : Drew Hess <src@drewhess.com>+Stability : experimental+Portability : non-portable++Basic GPIO types.++-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Trustworthy #-}++#ifndef MIN_VERSION_base+#define MIN_VERSION_base(x,y,z) 1+#endif++module System.GPIO.Types+ ( -- * GPIO pins+ Pin(..)+ , PinInputMode(..)+ , PinOutputMode(..)+ , PinCapabilities(..)+ , PinDirection(..)+ , PinActiveLevel(..)+ , PinValue(..)+ , PinInterruptMode(..)+ -- * Convenience functions+ , pinNumber+ , invertDirection+ , invertValue+ -- * PinValue conversion to/from Bool+ , valueToBool+ , boolToValue+ -- * GPIO exceptions+ , SomeGpioException(..)+ , gpioExceptionToException+ , gpioExceptionFromException+ ) where++import Control.Exception (Exception(..), SomeException)+import Data.Bits+import Data.Data+import Data.Ix+import Data.Set (Set)+import GHC.Generics+import Test.QuickCheck (Arbitrary(..), arbitraryBoundedEnum, genericShrink)++-- | A GPIO pin, identified by pin number.+--+-- Note that GPIO pin numbering is platform- and runtime-dependent.+-- See the documentation for your particular platform for an+-- explanation of how pin numbers are assigned to physical pins.+newtype Pin =+ Pin Int+ deriving (Bounded,Enum,Eq,Data,Ord,Read,Ix,Show,Generic,Typeable)++instance Arbitrary Pin where+ arbitrary = arbitraryBoundedEnum+ shrink = genericShrink++-- | Get the pin number as an 'Int'.+--+-- >>> pinNumber (Pin 5)+-- 5+pinNumber :: Pin -> Int+pinNumber (Pin n) = n++-- | GPIO pins may support a number of different physical+-- configurations when used as a digital input.+--+-- Pins that are capable of input will at least support the+-- 'InputDefault' mode. 'InputDefault' mode is special in that, unlike+-- the other input modes, it does not represent a unique physical+-- configuration, but is simply a pseudonym for another (actual) input+-- mode. Exactly which mode is used by the hardware when+-- 'InputDefault' mode is specified is platform-dependent. By using+-- 'InputDefaut' mode, you are saying that you don't care about the+-- pin's actual configuration, other than the fact that it's being+-- used for input.+data PinInputMode+ = InputDefault+ -- ^ The pin's default input mode, i.e., the mode used when a more+ -- specific mode is not specified+ | InputFloating+ -- ^ A floating \/ high-impedance \/ tri-state mode which uses+ -- little power, but when disconnected, may cause the pin's value+ -- to be indeterminate+ | InputPullUp+ -- ^ The pin is connected to an internal pull-up resistor such+ -- that, when the pin is disconnected or connected to a floating /+ -- high-impedance node, its physical value will be 'High'+ | InputPullDown+ -- ^ The pin is connected to an internal pull-down resistor such+ -- that, when the pin is disconnected or connected to a floating /+ -- high-impedance node, its physical value will be 'Low'+ deriving (Bounded,Enum,Eq,Ord,Data,Read,Show,Generic,Typeable)++-- | GPIO pins may support a number of different physical+-- configurations when used as a digital output.+--+-- Pins that are capable of output will at least support the+-- 'OutputDefault' mode. 'OutputDefault' mode is special in that,+-- unlike the other output modes, it does not represent a unique+-- physical configuration, but is simply a pseudonym for another+-- (actual) output mode. Exactly which mode is used by the hardware+-- when 'OutputDefault' mode is specified is platform-dependent. By+-- using 'OutputDefaut' mode, you are saying that you don't care about+-- the pin's actual configuration, other than the fact that it's being+-- used for output.+data PinOutputMode+ = OutputDefault+ -- ^ The pin's default output mode, i.e., the mode used when a+ -- more specific mode is not specified+ | OutputPushPull+ -- ^ The output actively drives both the 'High' and 'Low' states+ | OutputOpenDrain+ -- ^ The output actively drives the 'Low' state, but 'High' is+ -- left floating (also known as /open collector/)+ | OutputOpenDrainPullUp+ -- ^ The output actively drives the 'Low' state, and is connected+ -- to an internal pull-up resistor in the 'High' state.+ | OutputOpenSource+ -- ^ The output actively drives the 'High' state, but 'Low' is+ -- left floating (also known as /open emitter/)+ | OutputOpenSourcePullDown+ -- ^ The output actively drives the 'High' state, and is connected+ -- to an internal pull-down resistor in the 'Low' state.+ deriving (Bounded,Enum,Eq,Ord,Data,Read,Show,Generic,Typeable)++-- | Catalog a pin's capabilities.+data PinCapabilities =+ PinCapabilities {_inputModes :: Set PinInputMode+ -- ^ The set of input modes that the pin supports+ ,_outputModes :: Set PinOutputMode+ -- ^ The set of output modes that the pin supports+ ,_interrupts :: Bool+ -- ^ Does the pin support interrupts in input mode?+ }+ deriving (Eq,Show,Generic,Typeable)++-- | A pin's direction (input/output).+data PinDirection+ = In+ | Out+ deriving (Bounded,Enum,Eq,Data,Ord,Read,Show,Ix,Generic,Typeable)++instance Arbitrary PinDirection where+ arbitrary = arbitraryBoundedEnum+ shrink = genericShrink++-- | A pin's active level (active-high/active-low).+data PinActiveLevel+ = ActiveLow+ | ActiveHigh+ deriving (Bounded,Enum,Eq,Data,Ord,Read,Show,Ix,Generic,Typeable)++instance Arbitrary PinActiveLevel where+ arbitrary = arbitraryBoundedEnum+ shrink = genericShrink++-- | A pin's signal level as a binary value.+data PinValue+ = Low+ | High+ deriving (Bounded,Enum,Eq,Data,Ord,Read,Show,Ix,Generic,Typeable)++instance Bits PinValue where+ High .&. High = High+ _ .&. _ = Low++ Low .|. Low = Low+ _ .|. _ = High++ Low `xor` Low = Low+ Low `xor` High = High+ High `xor` Low = High+ High `xor` High = Low++ complement Low = High+ complement High = Low++ shift x 0 = x+ shift _ _ = Low++ rotate x _ = x++ bit 0 = High+ bit _ = Low++ testBit x 0 = valueToBool x+ testBit _ _ = False++ bitSizeMaybe _ = Just 1++ bitSize _ = 1++ isSigned _ = False++ popCount Low = 0+ popCount High = 1++instance FiniteBits PinValue where+ finiteBitSize _ = 1++#if MIN_VERSION_base(4,8,0)+ countTrailingZeros Low = 1+ countTrailingZeros High = 0++ countLeadingZeros = countTrailingZeros+#endif++instance Arbitrary PinValue where+ arbitrary = arbitraryBoundedEnum+ shrink = genericShrink++-- | A pin's interrupt mode.+--+-- Note that the pin's interrupt mode is defined in terms of the pin's+-- /logical/ signal value; i.e., when the pin is configured for+-- active-low logic, 'RisingEdge' refers to the physical signal's+-- trailing edge, and 'FallingEdge' refers to the physical signal's+-- rising edge.+data PinInterruptMode+ = Disabled+ -- ^ Interrupts are disabled+ | RisingEdge+ -- ^ Interrupt on the pin's (logical) rising edge+ | FallingEdge+ -- ^ Interrupt on the pin's (logical) falling edge+ | Level+ -- ^ Interrupt on any change to the pin's signal level+ deriving (Bounded,Enum,Eq,Data,Ord,Read,Show,Generic,Typeable)++instance Arbitrary PinInterruptMode where+ arbitrary = arbitraryBoundedEnum+ shrink = genericShrink++-- | Invert a 'PinDirection' value.+--+-- >>> invertDirection In+-- Out+-- >>> invertDirection Out+-- In+invertDirection :: PinDirection -> PinDirection+invertDirection In = Out+invertDirection Out = In++-- | Invert a 'PinValue'.+--+-- >>> invertValue High+-- Low+-- >>> invertValue Low+-- High+invertValue :: PinValue -> PinValue+invertValue = complement++-- | Convert a 'PinValue' to its logical boolean equivalent.+--+-- >>> valueToBool High+-- True+-- >>> valueToBool Low+-- False+valueToBool :: PinValue -> Bool+valueToBool Low = False+valueToBool High = True++-- | Convert a 'Bool' to its logical 'PinValue' equivalent.+--+-- >>> boolToValue True+-- High+-- >>> boolToValue False+-- Low+boolToValue :: Bool -> PinValue+boolToValue False = Low+boolToValue True = High++-- | The top level of the GPIO exception hierarchy.+data SomeGpioException = forall e . Exception e => SomeGpioException e+ deriving Typeable++instance Show SomeGpioException where+ show (SomeGpioException e) = show e++instance Exception SomeGpioException++-- | Convert 'SomeGpioException' to 'SomeException'.+gpioExceptionToException :: Exception e => e -> SomeException+gpioExceptionToException = toException . SomeGpioException++-- | Ask whether an exception is 'SomeGpioException'.+gpioExceptionFromException :: Exception e => SomeException -> Maybe e+gpioExceptionFromException x = do+ SomeGpioException a <- fromException x+ cast a
+ stack-lts-2.yaml view
@@ -0,0 +1,10 @@+require-stack-version: ">= 1.1.0"+pvp-bounds: both+resolver: lts-2.22+packages:+- .+extra-deps:+- unix-bytestring-0.3.7.3+flags:+ hpio:+ test-hlint: false
+ stack.yaml view
@@ -0,0 +1,8 @@+require-stack-version: ">= 1.1.0"+pvp-bounds: both+resolver: lts-6.0+packages:+- .+flags:+ hpio:+ test-hlint: false
+ test/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import Test.Hspec+import Spec++main :: IO ()+main = hspec spec
+ test/doctest.hs view
@@ -0,0 +1,24 @@+module Main where++import Data.Monoid ((<>))+import System.FilePath ((</>))+import Test.DocTest++addPrefix :: FilePath -> FilePath+addPrefix fp = "src" </> "System" </> "GPIO" </> fp++testFiles :: [FilePath]+testFiles =+ map addPrefix+ [ "Monad.hs"+ , "Tutorial.hs"+ , "Types.hs"+ , "Linux" </> "Sysfs" </> "Mock.hs"+ , "Linux" </> "Sysfs" </> "Mock" </> "Internal.hs"+ , "Linux" </> "Sysfs" </> "Monad.hs"+ , "Linux" </> "Sysfs" </> "Util.hs"+ , "Linux" </> "Sysfs" </> "Types.hs"+ ]++main :: IO ()+main = doctest (["-isrc"] <> testFiles)
+ test/hlint.hs view
@@ -0,0 +1,12 @@+module Main where++import Control.Monad (unless)+import Language.Haskell.HLint+import System.Environment+import System.Exit++main :: IO ()+main =+ do args <- getArgs+ hints <- hlint $ ["src", "--cpp-define=HLINT", "--cpp-ansi"] ++ args+ unless (null hints) exitFailure