diff --git a/.travis.yml b/.travis.yml new file mode 100644 --- /dev/null +++ b/.travis.yml @@ -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 diff --git a/Hlint.hs b/Hlint.hs new file mode 100644 --- /dev/null +++ b/Hlint.hs @@ -0,0 +1,4 @@ +import "hint" HLint.HLint + +ignore "Use import/export shortcut" + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. + +[![Travis CI build status](https://travis-ci.org/dhess/hpio.svg?branch=master)](https://travis-ci.org/dhess/hpio) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/default.nix b/default.nix new file mode 100644 --- /dev/null +++ b/default.nix @@ -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; +} diff --git a/examples/Gpio.hs b/examples/Gpio.hs new file mode 100644 --- /dev/null +++ b/examples/Gpio.hs @@ -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.") diff --git a/examples/GpioReader.hs b/examples/GpioReader.hs new file mode 100644 --- /dev/null +++ b/examples/GpioReader.hs @@ -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.") diff --git a/examples/Sysfs.hs b/examples/Sysfs.hs new file mode 100644 --- /dev/null +++ b/examples/Sysfs.hs @@ -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.") diff --git a/hpio.cabal b/hpio.cabal new file mode 100644 --- /dev/null +++ b/hpio.cabal @@ -0,0 +1,253 @@ +Name: hpio +Version: 0.8.0.0 +Cabal-Version: >= 1.10 +Build-Type: Simple +Author: Drew Hess +Maintainer: Drew Hess +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 diff --git a/shell.nix b/shell.nix new file mode 100644 --- /dev/null +++ b/shell.nix @@ -0,0 +1,45 @@ +{ nixpkgs ? import {}, 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 diff --git a/src/System/GPIO.hs b/src/System/GPIO.hs new file mode 100644 --- /dev/null +++ b/src/System/GPIO.hs @@ -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 +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 diff --git a/src/System/GPIO/Linux.hs b/src/System/GPIO/Linux.hs new file mode 100644 --- /dev/null +++ b/src/System/GPIO/Linux.hs @@ -0,0 +1,27 @@ +{-| +Module : System.GPIO.Linux +Description : Linux GPIO +Copyright : (c) 2016, Drew Hess +License : BSD3 +Maintainer : Drew Hess +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 diff --git a/src/System/GPIO/Linux/Sysfs.hs b/src/System/GPIO/Linux/Sysfs.hs new file mode 100644 --- /dev/null +++ b/src/System/GPIO/Linux/Sysfs.hs @@ -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 +Stability : experimental +Portability : non-portable + +GPIO in Linux via the @sysfs@ filesystem. + +See the +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 diff --git a/src/System/GPIO/Linux/Sysfs/IO.hs b/src/System/GPIO/Linux/Sysfs/IO.hs new file mode 100644 --- /dev/null +++ b/src/System/GPIO/Linux/Sysfs/IO.hs @@ -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 +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)) diff --git a/src/System/GPIO/Linux/Sysfs/Mock.hs b/src/System/GPIO/Linux/Sysfs/Mock.hs new file mode 100644 --- /dev/null +++ b/src/System/GPIO/Linux/Sysfs/Mock.hs @@ -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 +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 [] diff --git a/src/System/GPIO/Linux/Sysfs/Mock/Internal.hs b/src/System/GPIO/Linux/Sysfs/Mock/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/GPIO/Linux/Sysfs/Mock/Internal.hs @@ -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 +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) diff --git a/src/System/GPIO/Linux/Sysfs/Monad.hs b/src/System/GPIO/Linux/Sysfs/Monad.hs new file mode 100644 --- /dev/null +++ b/src/System/GPIO/Linux/Sysfs/Monad.hs @@ -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 +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 diff --git a/src/System/GPIO/Linux/Sysfs/Types.hs b/src/System/GPIO/Linux/Sysfs/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/GPIO/Linux/Sysfs/Types.hs @@ -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 +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 diff --git a/src/System/GPIO/Linux/Sysfs/Util.hs b/src/System/GPIO/Linux/Sysfs/Util.hs new file mode 100644 --- /dev/null +++ b/src/System/GPIO/Linux/Sysfs/Util.hs @@ -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 +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 +-- +-- 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 +-- +-- 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 diff --git a/src/System/GPIO/Linux/Sysfs/pollSysfs.c b/src/System/GPIO/Linux/Sysfs/pollSysfs.c new file mode 100644 --- /dev/null +++ b/src/System/GPIO/Linux/Sysfs/pollSysfs.c @@ -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 +#include +#include +#include + +/* + * 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; +} diff --git a/src/System/GPIO/Monad.hs b/src/System/GPIO/Monad.hs new file mode 100644 --- /dev/null +++ b/src/System/GPIO/Monad.hs @@ -0,0 +1,833 @@ +{-| +Module : System.GPIO.Monad +Description : A monad for GPIO computations +Copyright : (c) 2016, Drew Hess +License : BSD3 +Maintainer : Drew Hess +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) diff --git a/src/System/GPIO/Tutorial.hs b/src/System/GPIO/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/System/GPIO/Tutorial.hs @@ -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, +, 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 , +or the , 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 , +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 + +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 + +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 + 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 + +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 + +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 + 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 +. + +-} diff --git a/src/System/GPIO/Types.hs b/src/System/GPIO/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/GPIO/Types.hs @@ -0,0 +1,302 @@ +{-| +Module : System.GPIO.Types +Description : Basic GPIO types +Copyright : (c) 2016, Drew Hess +License : BSD3 +Maintainer : Drew Hess +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 diff --git a/stack-lts-2.yaml b/stack-lts-2.yaml new file mode 100644 --- /dev/null +++ b/stack-lts-2.yaml @@ -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 diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,8 @@ +require-stack-version: ">= 1.1.0" +pvp-bounds: both +resolver: lts-6.0 +packages: +- . +flags: + hpio: + test-hlint: false diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Test.Hspec +import Spec + +main :: IO () +main = hspec spec diff --git a/test/doctest.hs b/test/doctest.hs new file mode 100644 --- /dev/null +++ b/test/doctest.hs @@ -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) diff --git a/test/hlint.hs b/test/hlint.hs new file mode 100644 --- /dev/null +++ b/test/hlint.hs @@ -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