diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -4,8 +4,8 @@ # Use new container infrastructure to enable caching sudo: false -# Choose a lightweight base image; we provide our own build tools. -language: c +# Do not choose a language; we provide our own build tools. +language: generic # Caching so the next build will be fast too. cache: @@ -34,9 +34,12 @@ - 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]}} + - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #GHC 8.0.2" + addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=cabal GHCVER=8.2.1 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #GHC 8.2.1" + addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.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. @@ -46,25 +49,25 @@ # 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="" + compiler: ": #stack default" + addons: {apt: {packages: [libgmp-dev]}} + - 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]}} + addons: {apt: {packages: [libgmp-dev]}} - - env: BUILD=stack ARGS="--resolver lts-3" STACK_YAML=stack-lts-2.yaml + - env: BUILD=stack ARGS="--resolver lts-3" STACK_YAML=stack-lts-3.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]}} + addons: {apt: {packages: [libgmp-dev]}} - - env: BUILD=stack ARGS="--resolver lts-6" + - env: BUILD=stack ARGS="--resolver lts-6" STACK_YAML=stack-lts-6.yaml compiler: ": #stack 7.10.3" - addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}} + addons: {apt: {packages: [libgmp-dev]}} - - env: BUILD=stack ARGS="--resolver lts-7" + - env: BUILD=stack ARGS="--resolver lts-7" STACK_YAML=stack-lts-7.yaml compiler: ": #stack 8.0.1" - addons: {apt: {packages: [ghc-8.0.1], sources: [hvr-ghc]}} + addons: {apt: {packages: [libgmp-dev]}} # Nightly builds are allowed to fail - env: BUILD=stack ARGS="--resolver nightly" @@ -73,12 +76,8 @@ # 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-7" - compiler: ": #stack 8.0.1 osx" + - env: BUILD=stack ARGS="" + compiler: ": #stack default osx" os: osx - env: BUILD=stack ARGS="--resolver nightly" @@ -94,7 +93,7 @@ - unset CC # We want to always allow newer versions of packages when building on GHC HEAD -- CABALARGS="" +- CABALARGS="--flags=-test-hlint" - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi # Download and unpack the stack executable @@ -103,24 +102,21 @@ - | 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 + travis_retry 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' + travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' fi # Use the more reliable S3 mirror of Hackage mkdir -p $HOME/.cabal echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config - echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config + echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config if [ "$CABALVER" != "1.16" ] then echo 'jobs: $ncpus' >> $HOME/.cabal/config fi -# Get the list of packages from the stack.yaml file -- PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') - install: - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" - if [ -f configure.ac ]; then autoreconf -i; fi @@ -133,6 +129,10 @@ cabal) cabal --version travis_retry cabal update + + # Get the list of packages from the stack.yaml file + PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') + cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES ;; esac @@ -154,8 +154,14 @@ cd $dir cabal check || [ "$CABALVER" == "1.16" ] cabal sdist - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && \ - (cd dist && cabal install --force-reinstalls "$SRC_TGZ") + PKGVER=$(cabal info . | awk '{print $2;exit}') + SRC_TGZ=$PKGVER.tar.gz + cd dist + tar zxfv "$SRC_TGZ" + cd "$PKGVER" + cabal configure --enable-tests $CABALARGS + cabal build + cabal test cd $ORIGDIR done ;; diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,23 @@ +## 0.9.0.0 (2017-10-02) + +Changes: + - This project now uses Protolude (0.2.*). I believe the only visible + API change is that SysfsException's string type is now Text, + instead of String. + - Add monad and transformer instances for transformers-base, + monad-control, and monad-logger monads. + - Use DefaultSignatures and ConstraintKinds to simplify the + implementation. + - Use hpack to generate the project's Cabal file. + +Fixes: + - Add some new compile-time warnings. + - Remove redundant Functor and Applicative constraints. + - Update Travis-CI config to test against more recent Stackage LTS + and GHC releases. + - Remove most of the Travis-CI macOS jobs; they're really slow. + - Get all supported GHC/Stackage LTS versions to build again. + ## 0.8.0.10 (2017-06-28) Fixes: diff --git a/default.nix b/default.nix --- a/default.nix +++ b/default.nix @@ -1,29 +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, async, base, bytestring, containers, directory +, doctest, exceptions, filepath, hlint, hspec, monad-control +, monad-logger, mtl, optparse-applicative, protolude, QuickCheck +, stdenv, text, transformers, transformers-base, unix +, unix-bytestring }: mkDerivation { pname = "hpio"; - version = "0.8.0.10"; + version = "0.9.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 + base bytestring containers directory exceptions filepath + monad-control monad-logger mtl protolude QuickCheck text + transformers transformers-base unix unix-bytestring ]; executableHaskellDepends = [ - async base base-compat exceptions mtl mtl-compat - optparse-applicative transformers transformers-compat + async base exceptions mtl optparse-applicative protolude text + transformers ]; testHaskellDepends = [ - async base base-compat bytestring containers directory doctest - exceptions filepath hlint hspec mtl mtl-compat QuickCheck text - transformers transformers-compat unix unix-bytestring + base containers directory doctest exceptions filepath hlint hspec + protolude QuickCheck ]; - homepage = "https://github.com/quixoftic/hpio"; + homepage = "https://github.com/quixoftic/hpio#readme"; description = "Monads for GPIO in Haskell"; license = stdenv.lib.licenses.bsd3; } diff --git a/examples/Gpio.hs b/examples/Gpio.hs --- a/examples/Gpio.hs +++ b/examples/Gpio.hs @@ -1,18 +1,26 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (concurrently) -import Control.Monad (forever, void) +-- Protolude uses <> and options from Semigroups, but +-- optparse-applicative hasn't caught up yet. +import Protolude hiding ((<>)) import Control.Monad.Catch (MonadMask) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Foldable (for_) import Data.Monoid ((<>)) +import Data.Text (unwords) import Options.Applicative + (Parser, argument, auto, command, execParser, fullDesc, header, + help, helper, hsubparser, info, long, metavar, progDesc, short, + showDefault, value) +import qualified Options.Applicative as Options (option) import System.GPIO.Linux.Sysfs (runSysfsGpioIO) import System.GPIO.Monad + (MonadGpio, Pin, PinInputMode(..), PinInterruptMode(..), + PinOutputMode(..), PinValue(..), pins, pollPinTimeout, + setPinInputMode, setPinInterruptMode, setPinOutputMode, togglePin, + withPin) -- Only one for now. data Interpreter = @@ -46,75 +54,76 @@ 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)") <*> + Options.option auto (long "period" <> + short 'p' <> + metavar "INT" <> + value oneSecond <> + showDefault <> + help "Delay between output pin value toggles (in microseconds)") <*> + Options.option auto (long "trigger" <> + short 't' <> + metavar "Disabled|RisingEdge|FallingEdge|Level" <> + value Level <> + showDefault <> + help "Event on which to trigger the input pin") <*> + Options.option auto (long "timeout" <> + short 'T' <> + metavar "INT" <> + value (-1) <> + help "Poll timeout (in microseconds)") <*> argument auto (metavar "INPIN") <*> argument auto (metavar "OUTPIN") cmds :: Parser GlobalOptions cmds = GlobalOptions <$> - option auto (long "interpreter" <> - short 'i' <> - metavar "SysfsIO" <> - value SysfsIO <> - showDefault <> - help "Choose the GPIO interpreter (system) to use") <*> + Options.option auto (long "interpreter" <> + short 'i' <> + metavar "SysfsIO" <> + value SysfsIO <> + showDefault <> + help "Choose the GPIO interpreter (system) to use") <*> hsubparser (command "listPins" (info listPinsCmd (progDesc "List the GPIO pins available on the system")) <> command "pollPin" (info pollPinCmd (progDesc "Drive INPIN using OUTPIN and wait for interrupts. (Make sure the pins are connected!"))) run :: GlobalOptions -> IO () -run (GlobalOptions SysfsIO (PollPin (PollPinOptions period trigger to inputPin outputPin))) = +run (GlobalOptions SysfsIO (PollPin (PollPinOptions period trigger timeout inputPin outputPin))) = void $ concurrently - (void $ runSysfsGpioIO $ pollInput inputPin trigger to) + (void $ runSysfsGpioIO $ pollInput inputPin trigger timeout) (runSysfsGpioIO $ driveOutput outputPin period) run (GlobalOptions SysfsIO ListPins) = runSysfsGpioIO listPins -output :: (MonadIO m) => String -> m () -output = liftIO . putStrLn +-- | Define a constraint that can work with multiple 'MonadGpio' +-- interpreters. +type GpioM h m = (Applicative m, MonadMask m, MonadIO m, MonadGpio h m) -listPins :: (Applicative m, MonadIO m, MonadGpio h m) => m () +listPins :: (GpioM h m) => m () listPins = pins >>= \case - [] -> output "No GPIO pins found on this system" + [] -> putText "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 = +pollInput :: (GpioM h m) => Pin -> PinInterruptMode -> Int -> m () +pollInput p trigger timeout = withPin p $ \h -> do setPinInputMode h InputDefault setPinInterruptMode h trigger forever $ - do result <- pollPinTimeout h to + do result <- pollPinTimeout h timeout case result of - Nothing -> output ("readPin timed out after " ++ show to ++ " microseconds") - Just v -> output ("Input: " ++ show v) + Nothing -> putText $ unwords ["readPin timed out after", show timeout, "microseconds"] + Just v -> putText $ unwords ["Input:", show v] -driveOutput :: (MonadMask m, MonadIO m, MonadGpio h m) => Pin -> Int -> m () +driveOutput :: (GpioM 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) + putText $ unwords ["Output:", show v] main :: IO () main =execParser opts >>= run diff --git a/examples/GpioReader.hs b/examples/GpioReader.hs --- a/examples/GpioReader.hs +++ b/examples/GpioReader.hs @@ -5,23 +5,30 @@ -} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (concurrently) -import Control.Monad (forever, void) +-- Protolude uses <> and options from Semigroups, but +-- optparse-applicative hasn't caught up yet. +import Protolude hiding ((<>)) import Control.Monad.Catch (MonadMask) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Reader (MonadReader(..), ReaderT(..), asks) -import Data.Foldable (for_) import Data.Monoid ((<>)) +import Data.Text (unwords) import Options.Applicative + (Parser, argument, auto, command, execParser, fullDesc, header, + help, helper, hsubparser, info, long, metavar, progDesc, short, + showDefault, value) +import qualified Options.Applicative as Options (option) import System.GPIO.Linux.Sysfs (SysfsIOT, SysfsGpioT, runSysfsGpioT, runSysfsIOT, runSysfsGpioIO) import System.GPIO.Monad + (MonadGpio, Pin, PinInputMode(..), PinInterruptMode(..), + PinOutputMode(..), PinValue(..), pins, pollPinTimeout, + setPinInputMode, setPinInterruptMode, setPinOutputMode, togglePin, + withPin) -- Only one for now. data Interpreter = @@ -41,7 +48,7 @@ data PollPinOptions = PollPinOptions {_period :: !Int - ,_trigger :: !PinInterruptMode + ,_interruptMode :: !PinInterruptMode ,_timeout :: !Int ,_outputPin :: !Pin ,_inputPin :: !Pin} @@ -55,43 +62,43 @@ 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)") <*> + Options.option auto (long "period" <> + short 'p' <> + metavar "INT" <> + value oneSecond <> + showDefault <> + help "Delay between output pin value toggles (in microseconds)") <*> + Options.option auto (long "trigger" <> + short 't' <> + metavar "Disabled|RisingEdge|FallingEdge|Level" <> + value Level <> + showDefault <> + help "Event on which to trigger the input pin") <*> + Options.option auto (long "timeout" <> + short 'T' <> + metavar "INT" <> + value (-1) <> + help "Poll timeout (in microseconds)") <*> argument auto (metavar "INPIN") <*> argument auto (metavar "OUTPIN") cmds :: Parser GlobalOptions cmds = GlobalOptions <$> - option auto (long "interpreter" <> - short 'i' <> - metavar "SysfsIO" <> - value SysfsIO <> - showDefault <> - help "Choose the GPIO interpreter (system) to use") <*> + Options.option auto (long "interpreter" <> + short 'i' <> + metavar "SysfsIO" <> + value SysfsIO <> + showDefault <> + help "Choose the GPIO interpreter (system) to use") <*> hsubparser (command "listPins" (info listPinsCmd (progDesc "List the GPIO pins available on the system")) <> command "pollPin" (info pollPinCmd (progDesc "Drive INPIN using OUTPIN. (Make sure the pins are connected!"))) data Config = - Config {pin :: Pin - ,trigger :: PinInterruptMode - ,wait :: Int} + Config {_pin :: Pin + ,_trigger :: PinInterruptMode + ,_wait :: Int} deriving ((Show)) -- | Our 'IO' transformer stack: @@ -106,48 +113,50 @@ runSysfsGpioReaderIO act config = runSysfsIOT $ runSysfsGpioT $ runReaderT act config run :: GlobalOptions -> IO () -run (GlobalOptions SysfsIO (PollPin (PollPinOptions period mode to inputPin outputPin))) = +run (GlobalOptions SysfsIO (PollPin (PollPinOptions period mode timeout inputPin outputPin))) = void $ concurrently - (runSysfsGpioReaderIO pollInput (Config inputPin mode to)) + (runSysfsGpioReaderIO pollInput (Config inputPin mode timeout)) (runSysfsGpioReaderIO driveOutput (Config outputPin Disabled period)) -- The 'listPins' program takes no arguments, so we don't need our -- custom 'IO' transformer stack here. run (GlobalOptions SysfsIO ListPins) = runSysfsGpioIO listPins -output :: (MonadIO m) => String -> m () -output = liftIO . putStrLn +-- | Define some constraint types that work with multiple 'MonadGpio' +-- interpreters. +type GpioM h m = (Applicative m, MonadMask m, MonadIO m, MonadGpio h m) +type GpioReaderM h m = (Applicative m, MonadMask m, MonadIO m, MonadGpio h m, MonadReader Config m) -listPins :: (Applicative m, MonadIO m, MonadGpio h m) => m () +listPins :: (GpioM h m) => m () listPins = pins >>= \case - [] -> output "No GPIO pins found on this system" - ps -> for_ ps $ liftIO . print + [] -> putText "No GPIO pins found on this system" + ps -> for_ ps $ putText . show -pollInput :: (MonadMask m, MonadIO m, MonadGpio h m, MonadReader Config m) => m () +pollInput :: (GpioReaderM h m) => m () pollInput = - do p <- asks pin - mode <- asks trigger - timeout <- asks wait + 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) + Nothing -> putText $ unwords ["readPin timed out after", show timeout, "microseconds"] + Just v -> putText $ unwords ["Input:", show v] -driveOutput :: (MonadMask m, MonadIO m, MonadGpio h m, MonadReader Config m) => m () +driveOutput :: (GpioReaderM h m) => m () driveOutput = - do p <- asks pin - delay <- asks wait + 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) + putText $ unwords ["Output:", show v] main :: IO () main = execParser opts >>= run diff --git a/examples/Sysfs.hs b/examples/Sysfs.hs --- a/examples/Sysfs.hs +++ b/examples/Sysfs.hs @@ -12,18 +12,22 @@ 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_) +-- Protolude uses <> and options from Semigroups, but +-- optparse-applicative hasn't caught up yet. +import Protolude hiding ((<>)) import Data.Monoid ((<>)) +import Data.Text (unwords) import Options.Applicative + (Parser, argument, auto, command, execParser, fullDesc, header, + help, helper, hsubparser, info, long, metavar, progDesc, short, + showDefault, value) +import qualified Options.Applicative as Options (option) import System.GPIO.Linux.Sysfs.IO (SysfsIOT(..)) import System.GPIO.Linux.Sysfs.Monad -import System.GPIO.Linux.Sysfs.Types -import System.GPIO.Types + (availablePins, exportPin, pollPinValueTimeout, readPinValue, + unexportPin, writePinDirection, writePinEdge, writePinValue) +import System.GPIO.Linux.Sysfs.Types (SysfsEdge(..)) +import System.GPIO.Types (Pin, PinDirection(..), invertValue) data GlobalOptions = GlobalOptions {_cmd :: !Command} @@ -51,23 +55,23 @@ 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)") <*> + Options.option auto (long "period" <> + short 'p' <> + metavar "INT" <> + value oneSecond <> + showDefault <> + help "Delay between output pin value toggles (in microseconds)") <*> + Options.option auto (long "edge" <> + short 'e' <> + metavar "None|Rising|Falling|Both" <> + value Both <> + showDefault <> + help "Edge on which to trigger the input pin") <*> + Options.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") @@ -84,10 +88,10 @@ runNativeSysfs = runSysfsIOT run :: GlobalOptions -> IO () -run (GlobalOptions (ReadEdge (ReadEdgeOptions period edge to inputPin outputPin))) = +run (GlobalOptions (ReadEdge (ReadEdgeOptions period edge timeout inputPin outputPin))) = void $ concurrently - (runNativeSysfs $ edgeRead inputPin edge to) + (runNativeSysfs $ edgeRead inputPin edge timeout) (runNativeSysfs $ driveOutput outputPin period) run (GlobalOptions ListPins) = runNativeSysfs listPins @@ -97,19 +101,19 @@ listPins :: NativeSysfs () listPins = availablePins >>= \case - [] -> liftIO $ putStrLn "No GPIO pins found on this system" - ps -> for_ ps $ liftIO . print + [] -> putText "No GPIO pins found on this system" + ps -> for_ ps $ putText . show edgeRead :: Pin -> SysfsEdge -> Int -> NativeSysfs () -edgeRead p edge to = +edgeRead p edge timeout = withPin p $ do writePinDirection p In writePinEdge p edge forever $ - do result <- pollPinValueTimeout p to + do result <- pollPinValueTimeout p timeout case result of - Nothing -> liftIO $ putStrLn ("readPin timed out after " ++ show to ++ " microseconds") - Just v -> liftIO $ putStrLn ("Input: " ++ show v) + Nothing -> putText $ unwords ["readPin timed out after", show timeout, "microseconds"] + Just v -> putText $ unwords ["Input:", show v] driveOutput :: Pin -> Int -> NativeSysfs () driveOutput p delay = @@ -120,7 +124,7 @@ v <- readPinValue p let notv = invertValue v writePinValue p notv - liftIO $ putStrLn ("Output: " ++ show notv) + putText $ unwords ["Output:", show notv] main :: IO () main =execParser opts >>= run diff --git a/hpio.cabal b/hpio.cabal --- a/hpio.cabal +++ b/hpio.cabal @@ -1,260 +1,274 @@ -Name: hpio -Version: 0.8.0.10 -Cabal-Version: >= 1.10 -Build-Type: Simple -Author: Drew Hess -Maintainer: Drew Hess -Homepage: https://github.com/quixoftic/hpio -Bug-Reports: https://github.com/quixoftic/hpio/issues/ -Stability: experimental -License: BSD3 -License-File: LICENSE -Copyright: Copyright (c) 2017, Quixoftic, LLC -Tested-With: GHC == 7.8.4, GHC == 7.10.2, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.0.2 -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 - , changelog.md - , 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. +-- This file has been generated from package.yaml by hpack version 0.18.1. -- --- > cabal test -flinux-bbone-tests -Flag linux-bbone-tests - Default: False - Manual: True +-- see: https://github.com/sol/hpack --- Build doctests -Flag test-doctests - Default: True - Manual: True +name: hpio +version: 0.9.0.0 +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. +category: System +stability: experimental +homepage: https://github.com/quixoftic/hpio#readme +bug-reports: https://github.com/quixoftic/hpio/issues +author: Drew Hess +maintainer: Drew Hess +copyright: Copyright (c) 2017, Quixoftic, LLC +license: BSD3 +license-file: LICENSE +tested-with: GHC==7.8.4 GHC==7.10.2 GHC==7.10.3 GHC==8.0.1 GHC==8.0.2 GHC==8.2.1 +build-type: Simple +cabal-version: >= 1.10 --- Build hlint test -Flag test-hlint - Default: True - Manual: True +extra-source-files: + .travis.yml + changelog.md + default.nix + Hlint.hs + README.md + shell.nix + stack-lts-2.yaml + stack.yaml --- Build the example programs -Flag examples - Default: True - Manual: True +source-repository head + type: git + location: https://github.com/quixoftic/hpio -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.11 - , 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.4 - , 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 +flag examples + description: Build the example programs + manual: True + default: True -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.15 - , transformers - , transformers-compat - Default-Language: Haskell2010 - Ghc-Options: -Wall -threaded +flag linux-bbone-tests + description: Enable Linux BeagleBone-specific tests. Disabled by default. See test/System/GPIO/Linux/Sysfs/BeagleBoneSpec.hs for requirements. Run with "cabal test -flinux-bbone-tests". -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 + manual: True + default: False -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 +flag test-doctests + description: Build doctests + manual: True + default: True - 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 +flag test-hlint + description: Build hlint test + manual: True + default: True -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 +library + hs-source-dirs: + src + default-extensions: NoImplicitPrelude + other-extensions: ConstraintKinds CPP DefaultSignatures DeriveDataTypeable DeriveGeneric ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InterruptibleFFI KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings PackageImports QuasiQuotes Safe TemplateHaskell Trustworthy TypeSynonymInstances UndecidableInstances + cc-options: -Wall + c-sources: + src/System/GPIO/Linux/Sysfs/pollSysfs.c + build-depends: + QuickCheck >=2.7.6 && <2.11 + , base >=4.7.0 && <5 + , bytestring >=0.10.4 && <0.11 + , containers >=0.5.5 && <0.6 + , directory >=1.2.1 && <1.4 + , exceptions >=0.8.0 && <1 + , filepath >=1.3.0 && <1.5 + , monad-control == 1.* + , monad-logger == 0.3.* + , mtl >=2.1.3 && <2.3 + , protolude == 0.2.* + , text >=1.2.0 && <1.3 + , transformers >=0.3.0 && <0.6 + , transformers-base == 0.4.* + , unix >=2.7.0 && <2.8 + , unix-bytestring >=0.3.7 && <0.4 + if impl(ghc >= 8.0) + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + else + ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + else + build-depends: + fail == 4.9.* + , semigroups == 0.18.* + exposed-modules: + System.GPIO + System.GPIO.Linux + System.GPIO.Linux.Sysfs + System.GPIO.Linux.Sysfs.IO + System.GPIO.Linux.Sysfs.Mock + System.GPIO.Linux.Sysfs.Mock.Internal + System.GPIO.Linux.Sysfs.Monad + System.GPIO.Linux.Sysfs.Types + System.GPIO.Linux.Sysfs.Util + System.GPIO.Monad + System.GPIO.Tutorial + System.GPIO.Types + other-modules: + Paths_hpio + default-language: Haskell2010 -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 +executable hpio-example + main-is: Gpio.hs + hs-source-dirs: + examples + default-extensions: NoImplicitPrelude + other-extensions: ConstraintKinds LambdaCase OverloadedStrings + ghc-options: -threaded + if impl(ghc >= 8.0) + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + else + ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + if !(flag(examples)) + buildable: False + else + build-depends: + base + , async >=2.0.2 && <2.2 + , exceptions + , hpio + , mtl + , optparse-applicative >=0.11.0 && <0.15 + , protolude + , text + , transformers + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances -fno-warn-redundant-constraints -fno-warn-redundant-constraints + default-language: Haskell2010 -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 - , 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 - , Spec - , System.GPIO.TypesSpec - , System.GPIO.Linux.Sysfs.LinuxBboneSpec - , System.GPIO.Linux.Sysfs.MockInternalSpec - , System.GPIO.Linux.Sysfs.MockSpec - , System.GPIO.Linux.Sysfs.SysfsGpioMockSpec - C-Sources: src/System/GPIO/Linux/Sysfs/pollSysfs.c - If flag(linux-bbone-tests) - cpp-options: -DRUN_LINUX_BBONE_TESTS=1 +executable hpio-reader-example + main-is: GpioReader.hs + hs-source-dirs: + examples + default-extensions: NoImplicitPrelude + other-extensions: ConstraintKinds FlexibleContexts LambdaCase OverloadedStrings + ghc-options: -threaded + if impl(ghc >= 8.0) + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + else + ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + if !(flag(examples)) + buildable: False + else + build-depends: + base + , async >=2.0.2 && <2.2 + , exceptions + , hpio + , mtl + , optparse-applicative >=0.11.0 && <0.15 + , protolude + , text + , transformers + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances -fno-warn-redundant-constraints -fno-warn-redundant-constraints + default-language: Haskell2010 -Source-Repository head - Type: git - Location: git://github.com/quixoftic/hpio.git +executable hpio-sysfs-example + main-is: Sysfs.hs + hs-source-dirs: + examples + default-extensions: NoImplicitPrelude + other-extensions: FlexibleContexts LambdaCase OverloadedStrings + ghc-options: -threaded + if impl(ghc >= 8.0) + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + else + ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + if !(flag(examples)) + buildable: False + else + build-depends: + base + , async >=2.0.2 && <2.2 + , exceptions + , hpio + , mtl + , optparse-applicative >=0.11.0 && <0.15 + , protolude + , text + , transformers + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances -fno-warn-redundant-constraints -fno-warn-redundant-constraints + default-language: Haskell2010 -Source-Repository this - Type: git - Location: git://github.com/quixoftic/hpio.git - Tag: v0.8.0.10 +test-suite doctest + type: exitcode-stdio-1.0 + main-is: doctest.hs + hs-source-dirs: + test + default-extensions: NoImplicitPrelude + ghc-options: -threaded + if impl(ghc >= 8.0) + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + else + ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + if (!(flag(test-doctests))) || (impl(ghc <7.10)) + buildable: False + else + build-depends: + base + , doctest + , filepath + , protolude + default-language: Haskell2010 + +test-suite hlint + type: exitcode-stdio-1.0 + main-is: hlint.hs + hs-source-dirs: + test + default-extensions: NoImplicitPrelude + ghc-options: -w -threaded + if impl(ghc >= 8.0) + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + else + ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + if !(flag(test-hlint)) + buildable: False + else + build-depends: + base + , hlint + , protolude + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + default-extensions: NoImplicitPrelude + ghc-options: -threaded + build-depends: + base + , containers + , directory + , exceptions + , filepath + , hpio + , hspec >=2.1.7 + , protolude + , QuickCheck + if impl(ghc >= 8.0) + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates + else + ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates + if flag(linux-bbone-tests) + cpp-options: -DRUN_LINUX_BBONE_TESTS=1 + other-modules: + Test.System.GPIO.Linux.Sysfs.LinuxBboneSpec + Test.System.GPIO.Linux.Sysfs.MockInternalSpec + Test.System.GPIO.Linux.Sysfs.MockSpec + Test.System.GPIO.Linux.Sysfs.SysfsGpioMockSpec + Test.System.GPIO.TypesSpec + default-language: Haskell2010 diff --git a/shell.nix b/shell.nix --- a/shell.nix +++ b/shell.nix @@ -1,35 +1,35 @@ -{ nixpkgs ? import {}, compiler ? "default" }: +{ nixpkgs ? import {}, compiler ? "default", doBenchmark ? false }: 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 + f = { mkDerivation, async, base, bytestring, containers + , directory, doctest, exceptions, filepath, hlint, hspec + , monad-control, monad-logger, mtl, optparse-applicative, protolude + , QuickCheck, stdenv, text, transformers, transformers-base, unix + , unix-bytestring }: mkDerivation { pname = "hpio"; - version = "0.8.0.10"; + version = "0.9.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 + base bytestring containers directory exceptions filepath + monad-control monad-logger mtl protolude QuickCheck text + transformers transformers-base unix unix-bytestring ]; executableHaskellDepends = [ - async base base-compat exceptions mtl mtl-compat - optparse-applicative transformers transformers-compat + async base exceptions mtl optparse-applicative protolude text + transformers ]; testHaskellDepends = [ - async base base-compat bytestring containers directory doctest - exceptions filepath hlint hspec mtl mtl-compat QuickCheck text - transformers transformers-compat unix unix-bytestring + base containers directory doctest exceptions filepath hlint hspec + protolude QuickCheck ]; - homepage = "https://github.com/quixoftic/hpio"; + homepage = "https://github.com/quixoftic/hpio#readme"; description = "Monads for GPIO in Haskell"; license = stdenv.lib.licenses.bsd3; }; @@ -38,14 +38,9 @@ then pkgs.haskellPackages else pkgs.haskell.packages.${compiler}; - # Test with optparse-applicative-0.13.0.0. - # modifiedHaskellPackages = haskellPackages.override { - # overrides = self: super: { - # optparse-applicative = self.optparse-applicative_0_13_0_0; - # }; - # }; - #drv = modifiedHaskellPackages.callPackage f {}; - drv = haskellPackages.callPackage f {}; + variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id; + + drv = variant (haskellPackages.callPackage f {}); in diff --git a/src/System/GPIO.hs b/src/System/GPIO.hs --- a/src/System/GPIO.hs +++ b/src/System/GPIO.hs @@ -14,11 +14,8 @@ {-# LANGUAGE Safe #-} module System.GPIO - ( -- * The MonadGpio class - module System.GPIO.Monad - -- * GPIO in Linux - , module System.GPIO.Linux + ( module X ) where -import System.GPIO.Monad -import System.GPIO.Linux +import System.GPIO.Monad as X +import System.GPIO.Linux as X diff --git a/src/System/GPIO/Linux.hs b/src/System/GPIO/Linux.hs --- a/src/System/GPIO/Linux.hs +++ b/src/System/GPIO/Linux.hs @@ -20,8 +20,7 @@ {-# LANGUAGE Safe #-} module System.GPIO.Linux - ( -- * Linux @sysfs@ GPIO - module System.GPIO.Linux.Sysfs + ( module X ) where -import System.GPIO.Linux.Sysfs +import System.GPIO.Linux.Sysfs as X diff --git a/src/System/GPIO/Linux/Sysfs.hs b/src/System/GPIO/Linux/Sysfs.hs --- a/src/System/GPIO/Linux/Sysfs.hs +++ b/src/System/GPIO/Linux/Sysfs.hs @@ -102,6 +102,7 @@ , SysfsException(..) ) where +import Protolude import System.GPIO.Linux.Sysfs.Monad import System.GPIO.Linux.Sysfs.IO import System.GPIO.Linux.Sysfs.Types diff --git a/src/System/GPIO/Linux/Sysfs/IO.hs b/src/System/GPIO/Linux/Sysfs/IO.hs --- a/src/System/GPIO/Linux/Sysfs/IO.hs +++ b/src/System/GPIO/Linux/Sysfs/IO.hs @@ -13,33 +13,34 @@ -} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InterruptibleFFI #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} 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 Protolude hiding (bracket) +import Control.Monad.Base (MonadBase) 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.Logger (MonadLogger, MonadLoggerIO) import Control.Monad.RWS (MonadRWS) -import Control.Monad.State (MonadState) -import Control.Monad.Trans.Class (MonadTrans, lift) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Control + (ComposeSt, MonadBaseControl(..), MonadTransControl(..), + defaultLiftBaseWith, defaultRestoreM) 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(..)) @@ -70,12 +71,45 @@ -- (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) +newtype SysfsIOT m a = SysfsIOT + { runSysfsIOT :: m a + } deriving ( Functor + , Alternative + , Applicative + , Monad + , MonadBase b + , MonadFix + , MonadPlus + , MonadThrow + , MonadCatch + , MonadMask + , MonadCont + , MonadIO + , MonadReader r + , MonadError e + , MonadWriter w + , MonadState s + , MonadRWS r w s + , MonadLogger + , MonadLoggerIO + ) instance MonadTrans SysfsIOT where lift = SysfsIOT + +instance MonadBaseControl b m => MonadBaseControl b (SysfsIOT m) where + type StM (SysfsIOT m) a = ComposeSt SysfsIOT m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINABLE liftBaseWith #-} + {-# INLINABLE restoreM #-} + +instance MonadTransControl SysfsIOT where + type StT SysfsIOT a = a + liftWith f = SysfsIOT $ f runSysfsIOT + restoreT = SysfsIOT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} instance (MonadIO m, MonadThrow m) => MonadSysfs (SysfsIOT m) where doesDirectoryExist = liftIO . D.doesDirectoryExist diff --git a/src/System/GPIO/Linux/Sysfs/Mock.hs b/src/System/GPIO/Linux/Sysfs/Mock.hs --- a/src/System/GPIO/Linux/Sysfs/Mock.hs +++ b/src/System/GPIO/Linux/Sysfs/Mock.hs @@ -15,11 +15,16 @@ -} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} module System.GPIO.Linux.Sysfs.Mock ( -- * SysfsMock types @@ -79,32 +84,30 @@ , 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 Protolude + hiding (StateT, execStateT, readFile, runStateT, writeFile) +import Control.Monad.Base (MonadBase) 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.Logger (MonadLogger, MonadLoggerIO) +import Control.Monad.State.Strict (StateT(..), execStateT) import Control.Monad.Trans.Class (MonadTrans) +import Control.Monad.Trans.Control + (ComposeSt, MonadBaseControl(..), MonadTransControl(..), + defaultLiftBaseWith, defaultLiftWith, defaultRestoreM, + defaultRestoreT) 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 qualified Data.ByteString.Char8 as C8 (unlines) +import Data.List (length) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map (empty, insert, insertLookupWithKey, lookup) -import Data.Typeable (Typeable) +import Data.Text (unwords) import Foreign.C.Types (CInt(..)) import GHC.IO.Exception (IOErrorType(..)) import System.FilePath ((), splitFileName) -import System.IO.Error (mkIOError) +import System.IO.Error (IOError, mkIOError) import System.GPIO.Linux.Sysfs.Mock.Internal (Directory, File(..), FileType(..), MockFSZipper(..), directory, @@ -191,7 +194,7 @@ -- @\/sys\/class\/gpio\/gpioN@, where @N@ is @_base@ + the pin's index -- in the '_initialPinStates' list. data MockGpioChip = - MockGpioChip {_label :: !String + MockGpioChip {_label :: !Text -- ^ The name given to the chip in the filesystem ,_base :: !Int -- ^ The pin number of the chip's first pin @@ -245,33 +248,69 @@ -- | 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) +newtype SysfsMockT m a = SysfsMockT + { unSysfsMockT :: StateT MockWorld m a + } deriving ( Functor + , Alternative + , Applicative + , Monad + , MonadBase b + , MonadFix + , MonadPlus + , MonadThrow + , MonadCatch + , MonadMask + , MonadCont + , MonadIO + , MonadReader r + , MonadError e + , MonadWriter w + , MonadState MockWorld + , MonadLogger + , MonadLoggerIO + , MonadTrans + ) -getZipper :: (Monad m) => SysfsMockT m MockFSZipper +instance MonadBaseControl b m => MonadBaseControl b (SysfsMockT m) where + type StM (SysfsMockT m) a = ComposeSt SysfsMockT m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINABLE liftBaseWith #-} + {-# INLINABLE restoreM #-} + +instance MonadTransControl SysfsMockT where + type StT SysfsMockT a = StT (StateT MockWorld) a + liftWith = defaultLiftWith SysfsMockT unSysfsMockT + restoreT = defaultRestoreT SysfsMockT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +type MockM m = (Functor m, MonadThrow m) + +getZipper :: (MockM m) => SysfsMockT m MockFSZipper getZipper = gets _zipper -putZipper :: (Monad m) => MockFSZipper -> SysfsMockT m () +putZipper :: (MockM m) => MockFSZipper -> SysfsMockT m () putZipper z = do s <- get put $ s {_zipper = z} -getPins :: (Monad m) => SysfsMockT m MockPins +getPins :: (MockM m) => SysfsMockT m MockPins getPins = gets _pins -pinState :: (Functor m, MonadThrow m) => Pin -> SysfsMockT m MockPinState +pinState :: (MockM 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) + Nothing -> throwM $ InternalError $ + unwords ["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 :: (MockM m) => MockPins -> SysfsMockT m () putPins ps = do s <- get put $ s {_pins = ps} -putPinState :: (Functor m, MonadThrow m) => Pin -> (MockPinState -> MockPinState) -> SysfsMockT m () +putPinState :: (MockM m) => Pin -> (MockPinState -> MockPinState) -> SysfsMockT m () putPinState pin f = do ps <- pinState pin (Map.insert pin (f ps) <$> getPins) >>= putPins @@ -289,20 +328,20 @@ -- 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 :: (MockM 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 :: (MockM 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 :: (MockM 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 +instance (MockM m) => M.MonadSysfs (SysfsMockT m) where doesDirectoryExist = doesDirectoryExist doesFileExist = doesFileExist getDirectoryContents = getDirectoryContents @@ -450,7 +489,7 @@ = GpioChipOverlap Pin -- ^ The user has defined defined at least two 'MockGpioChip's -- with the same pin number, which is an invalid condition - | InternalError String + | InternalError Text -- ^ An internal error has occurred in the mock @sysfs@ -- interpreter, something which should "never happen" and should -- be reported to the package maintainer. @@ -460,12 +499,12 @@ toException = gpioExceptionToException fromException = gpioExceptionFromException -makeFileSystem :: (Functor m, MonadThrow m) => [MockGpioChip] -> SysfsMockT m MockFSZipper +makeFileSystem :: (MockM m) => [MockGpioChip] -> SysfsMockT m MockFSZipper makeFileSystem chips = do mapM_ makeChip chips getZipper -makeChip :: (Functor m, MonadThrow m) => MockGpioChip -> SysfsMockT m () +makeChip :: (MockM m) => MockGpioChip -> SysfsMockT m () makeChip chip = let chipdir = sysfsPath ("gpiochip" ++ show (_base chip)) in @@ -474,9 +513,9 @@ 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]) + mkfile (chipdir "base") (Constant [intToBS $ _base chip]) + mkfile (chipdir "ngpio") (Constant [intToBS $ length (_initialPinStates chip)]) + mkfile (chipdir "label") (Constant [toS $ _label chip]) addPins :: Int -> [MockPinState] -> MockPins -> Either MockFSException MockPins addPins base states pm = foldrM addPin pm (zip (map Pin [base..]) states) @@ -489,7 +528,7 @@ (Nothing, newPm) -> Right newPm (Just _, _) -> Left $ GpioChipOverlap pin -pushd :: (MonadThrow m) => FilePath -> SysfsMockT m a -> SysfsMockT m a +pushd :: (MockM m) => FilePath -> SysfsMockT m a -> SysfsMockT m a pushd path action = do z <- getZipper let restorePath = Internal.pathFromRoot z @@ -498,28 +537,28 @@ cd restorePath >>= putZipper return result -cd :: (MonadThrow m) => FilePath -> SysfsMockT m MockFSZipper +cd :: (MockM 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 :: (MockM 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 :: (MockM 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 :: (MockM m) => FilePath -> FileType -> SysfsMockT m () mkfile path filetype = let (parentName, childName) = splitFileName path in @@ -528,13 +567,13 @@ -- | Check whether the specified directory exists in the mock -- filesystem. -doesDirectoryExist :: (Monad m) => FilePath -> SysfsMockT m Bool +doesDirectoryExist :: (MockM 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 :: (MockM m) => FilePath -> SysfsMockT m Bool doesFileExist path = let (dirPath, fileName) = splitFileName path in @@ -546,13 +585,13 @@ -- | Get a directory listing for the specified directory in the mock -- filesystem. -getDirectoryContents :: (Functor m, MonadThrow m) => FilePath -> SysfsMockT m [FilePath] +getDirectoryContents :: (MockM 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 :: (MockM m) => FilePath -> SysfsMockT m ByteString readFile path = fileAt path >>= \case Nothing -> @@ -560,7 +599,7 @@ 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 (Constant 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) -> @@ -568,15 +607,18 @@ 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") + else throwM $ + InternalError $ + unwords ["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") + Nothing -> throwM $ InternalError $ + unwords ["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 :: (MockM 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 @@ -612,7 +654,8 @@ 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") + (Nothing, _) -> throwM $ InternalError $ + unwords ["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}) @@ -631,7 +674,8 @@ -- 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") + (False, _, _) -> throwM $ InternalError $ + unwords ["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}) @@ -647,7 +691,7 @@ permissionError :: IOError permissionError = mkIOError PermissionDenied "Mock.writeFile" Nothing (Just path) - export :: (Functor m, MonadThrow m) => Pin -> SysfsMockT m () + export :: (MockM m) => Pin -> SysfsMockT m () export pin = Map.lookup pin <$> getPins >>= \case Nothing -> throwM $ mkIOError InvalidArgument "Mock.writeFile" Nothing (Just path) @@ -665,14 +709,14 @@ when (isJust $ _edge s) $ mkfile (pinEdgeFileName pin) (Edge pin) - unexport :: (MonadThrow m) => Pin -> SysfsMockT m () + unexport :: (MockM 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 :: (MockM m) => FilePath -> SysfsMockT m (Maybe FileType) fileAt path = let (dirPath, fileName) = splitFileName path in @@ -681,12 +725,12 @@ -- | For the mock filesystem, this action is equivalent to -- 'writeFile'. -unlockedWriteFile :: (Functor m, MonadThrow m) => FilePath -> ByteString -> SysfsMockT m () +unlockedWriteFile :: (MockM 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 :: (MockM m) => FilePath -> Int -> SysfsMockT m CInt pollFile _ _ = return 1 -- | The initial directory structure of a @sysfs@ GPIO filesystem. diff --git a/src/System/GPIO/Linux/Sysfs/Mock/Internal.hs b/src/System/GPIO/Linux/Sysfs/Mock/Internal.hs --- a/src/System/GPIO/Linux/Sysfs/Mock/Internal.hs +++ b/src/System/GPIO/Linux/Sysfs/Mock/Internal.hs @@ -49,23 +49,18 @@ , 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 Protolude import Data.Tree (Tree(..)) import GHC.IO.Exception (IOErrorType(..)) import System.FilePath (isAbsolute, isValid, joinPath, splitDirectories) -import System.IO.Error (mkIOError) +import System.IO.Error (IOError, mkIOError) import System.GPIO.Types (Pin) -type Name = String +type Name = FilePath data FileType - = Const [ByteString] + = Constant [ByteString] | Export | Unexport | Value Pin diff --git a/src/System/GPIO/Linux/Sysfs/Monad.hs b/src/System/GPIO/Linux/Sysfs/Monad.hs --- a/src/System/GPIO/Linux/Sysfs/Monad.hs +++ b/src/System/GPIO/Linux/Sysfs/Monad.hs @@ -11,12 +11,17 @@ -} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module System.GPIO.Linux.Sysfs.Monad ( -- * MonadSysfs class @@ -24,6 +29,10 @@ -- * GPIO via @sysfs@ , PinDescriptor(..) , SysfsGpioT(..) + -- * Convenient constraint synonyms for 'MonadSysfs' signatures. + , CatchSysfsM + , ThrowSysfsM + , ThrowCatchSysfsM -- * Low-level @sysfs@ GPIO actions. -- -- If you wish, you can bypass the portable GPIO computation @@ -55,20 +64,19 @@ , writePinActiveLow ) where -import Prelude () -import Prelude.Compat hiding (readFile, writeFile) -import Control.Applicative (Alternative) -import Control.Monad (MonadPlus, filterM, void) +import Protolude hiding (readFile, writeFile) +import Control.Monad.Base (MonadBase) 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.Logger + (LoggingT, MonadLogger, MonadLoggerIO, NoLoggingT) import Control.Monad.RWS (MonadRWS) -import Control.Monad.State (MonadState) -import Control.Monad.Trans.Class (MonadTrans, lift) +import Control.Monad.Trans.Class (MonadTrans) +import Control.Monad.Trans.Control + (ComposeSt, MonadBaseControl(..), MonadTransControl(..), + defaultLiftBaseWith, defaultRestoreM) import Control.Monad.Trans.Identity (IdentityT) import "transformers" Control.Monad.Trans.List (ListT) import Control.Monad.Trans.Maybe (MaybeT) @@ -79,16 +87,14 @@ 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.ByteString.Char8 as C8 (readInt) 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) + (IOError, ioeGetErrorType, isAlreadyInUseError, + isDoesNotExistError, isPermissionError) import System.GPIO.Linux.Sysfs.Types (SysfsEdge(..), SysfsException(..), toPinInterruptMode, toSysfsEdge) import System.GPIO.Linux.Sysfs.Util @@ -105,16 +111,22 @@ -- | 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 @@ -122,6 +134,7 @@ -- 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 @@ -129,122 +142,51 @@ -- 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 + default doesDirectoryExist :: (MonadTrans t, MonadSysfs m', t m' ~ m) => + FilePath -> m Bool + default doesFileExist :: (MonadTrans t, MonadSysfs m', t m' ~ m) => + FilePath -> m Bool + default getDirectoryContents :: (MonadTrans t, MonadSysfs m', t m' ~ m) => + FilePath -> m [FilePath] + default readFile :: (MonadTrans t, MonadSysfs m', t m' ~ m) => + FilePath -> m ByteString + default writeFile :: (MonadTrans t, MonadSysfs m', t m' ~ m) => + FilePath -> ByteString -> m () + default unlockedWriteFile :: (MonadTrans t, MonadSysfs m', t m' ~ m) => + FilePath -> ByteString -> m () + default pollFile :: (MonadTrans t, MonadSysfs m', t m' ~ m) => + FilePath -> Int -> m CInt -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 + {-# INLINE doesDirectoryExist #-} doesFileExist = lift . doesFileExist + {-# INLINE doesFileExist #-} getDirectoryContents = lift . getDirectoryContents + {-# INLINE getDirectoryContents #-} readFile = lift . readFile + {-# INLINE readFile #-} writeFile fn bs = lift $ writeFile fn bs + {-# INLINE writeFile #-} unlockedWriteFile fn bs = lift $ unlockedWriteFile fn bs + {-# INLINE unlockedWriteFile #-} pollFile fn timeout = lift $ pollFile fn timeout + {-# INLINE pollFile #-} -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 +instance (MonadSysfs m) => MonadSysfs (IdentityT m) +instance (MonadSysfs m) => MonadSysfs (ContT r m) +instance (MonadSysfs m) => MonadSysfs (CatchT m) +instance (MonadSysfs m) => MonadSysfs (ExceptT e m) +instance (MonadSysfs m) => MonadSysfs (ListT m) +instance (MonadSysfs m) => MonadSysfs (MaybeT m) +instance (MonadSysfs m) => MonadSysfs (ReaderT r m) +instance (MonadSysfs m, Monoid w) => MonadSysfs (LazyRWS.RWST r w s m) +instance (MonadSysfs m, Monoid w) => MonadSysfs (StrictRWS.RWST r w s m) +instance (MonadSysfs m) => MonadSysfs (LazyState.StateT s m) +instance (MonadSysfs m) => MonadSysfs (StrictState.StateT s m) +instance (MonadSysfs m, Monoid w) => MonadSysfs (LazyWriter.WriterT w m) +instance (MonadSysfs m, Monoid w) => MonadSysfs (StrictWriter.WriterT w m) +instance (MonadSysfs m) => MonadSysfs (LoggingT m) +instance (MonadSysfs m) => MonadSysfs (NoLoggingT m) -- | The @sysfs@ pin handle type. Currently it's just a newtype -- wrapper around a 'Pin'. The constructor is exported for @@ -256,14 +198,51 @@ -- | 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) +newtype SysfsGpioT m a = SysfsGpioT + { runSysfsGpioT :: m a + } deriving ( Functor + , Alternative + , Applicative + , Monad + , MonadBase b + , MonadFix + , MonadPlus + , MonadThrow + , MonadCatch + , MonadMask + , MonadCont + , MonadIO + , MonadReader r + , MonadError e + , MonadWriter w + , MonadState s + , MonadRWS r w s + , MonadLogger + , MonadLoggerIO + ) instance MonadTrans SysfsGpioT where lift = SysfsGpioT -instance (Functor m, MonadCatch m, MonadMask m, MonadThrow m, MonadSysfs m) => MonadGpio PinDescriptor (SysfsGpioT m) where +instance MonadBaseControl b m => MonadBaseControl b (SysfsGpioT m) where + type StM (SysfsGpioT m) a = ComposeSt SysfsGpioT m a + liftBaseWith = defaultLiftBaseWith + restoreM = defaultRestoreM + {-# INLINABLE liftBaseWith #-} + {-# INLINABLE restoreM #-} + +instance MonadTransControl SysfsGpioT where + type StT SysfsGpioT a = a + liftWith f = SysfsGpioT $ f runSysfsGpioT + restoreT = SysfsGpioT + {-# INLINABLE liftWith #-} + {-# INLINABLE restoreT #-} + +type CatchSysfsM m = (Functor m, MonadCatch m, MonadSysfs m) +type ThrowSysfsM m = (Functor m, MonadThrow m, MonadSysfs m) +type ThrowCatchSysfsM m = (Functor m, MonadThrow m, MonadCatch m, MonadSysfs m) + +instance (MonadMask m, ThrowCatchSysfsM m) => MonadGpio PinDescriptor (SysfsGpioT m) where pins = lift sysfsIsPresent >>= \case False -> return [] @@ -388,7 +367,7 @@ -- -- 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 :: (CatchSysfsM m) => Pin -> m () exportPin pin@(Pin n) = catchIOError (unlockedWriteFile exportFileName (intToBS n)) @@ -406,7 +385,7 @@ -- 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 :: (CatchSysfsM m) => Pin -> m () exportPinChecked pin@(Pin n) = catchIOError (unlockedWriteFile exportFileName (intToBS n)) @@ -424,7 +403,7 @@ -- 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 :: (CatchSysfsM m) => Pin -> m () unexportPin pin@(Pin n) = catchIOError (unlockedWriteFile unexportFileName (intToBS n)) @@ -441,7 +420,7 @@ -- 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 :: (CatchSysfsM m) => Pin -> m () unexportPinChecked pin@(Pin n) = catchIOError (unlockedWriteFile unexportFileName (intToBS n)) @@ -457,7 +436,7 @@ -- 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 :: (ThrowSysfsM m) => Pin -> m Bool pinHasDirection p = do exported <- pinIsExported p if exported @@ -468,16 +447,16 @@ -- -- 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 :: (ThrowCatchSysfsM 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)) + x -> throwM $ UnexpectedDirection p (decodeUtf8 x)) mapIOError where - mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m PinDirection + mapIOError :: (ThrowSysfsM m) => IOError -> m PinDirection mapIOError e | isDoesNotExistError e = do exported <- pinIsExported p @@ -500,7 +479,7 @@ -- 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 :: (CatchSysfsM m) => Pin -> PinDirection -> m () writePinDirection p In = writeDirection p (pinDirectionToBS In) writePinDirection p Out = @@ -532,21 +511,21 @@ -- 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 :: (CatchSysfsM m) => Pin -> PinValue -> m () writePinDirectionWithValue p v = do activeLow <- readPinActiveLow p - let f = if activeLow then invertValue else id + let f = if activeLow then invertValue else identity resetEdge p writeDirection p (pinDirectionValueToBS $ f v) -resetEdge :: (MonadSysfs m, MonadCatch m) => Pin -> m () +resetEdge :: (CatchSysfsM 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 :: (CatchSysfsM m) => m (Maybe SysfsEdge) maybeReadPinEdge = pinHasEdge p >>= \case False -> return Nothing @@ -554,14 +533,13 @@ do edge <- readPinEdge p return $ Just edge - -writeDirection :: (MonadSysfs m, MonadCatch m) => Pin -> ByteString -> m () +writeDirection :: (CatchSysfsM m) => Pin -> ByteString -> m () writeDirection p bs = catchIOError (writeFile (pinDirectionFileName p) bs) mapIOError where - mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m () + mapIOError :: (ThrowSysfsM m) => IOError -> m () mapIOError e | isDoesNotExistError e = do exported <- pinIsExported p @@ -570,20 +548,21 @@ 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 :: (ThrowCatchSysfsM 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)) + x -> throwM $ UnexpectedValue p (decodeUtf8 x)) mapIOError where - mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m PinValue + mapIOError :: (ThrowSysfsM m) => IOError -> m PinValue mapIOError e | isDoesNotExistError e = throwM $ NotExported p | isPermissionError e = throwM $ PermissionDenied p @@ -595,7 +574,7 @@ -- -- 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 :: (ThrowCatchSysfsM m) => Pin -> m PinValue pollPinValue p = pollPinValueTimeout p (-1) >>= \case Just v -> return v @@ -623,7 +602,7 @@ -- 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 :: (ThrowCatchSysfsM m) => Pin -> Int -> m (Maybe PinValue) pollPinValueTimeout p timeout = catchIOError (do pollResult <- pollFile (pinValueFileName p) timeout @@ -632,7 +611,7 @@ else return Nothing) mapIOError where - mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m (Maybe PinValue) + mapIOError :: (ThrowSysfsM m) => IOError -> m (Maybe PinValue) mapIOError e | isDoesNotExistError e = throwM $ NotExported p | isPermissionError e = throwM $ PermissionDenied p @@ -642,13 +621,13 @@ -- -- 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 :: (CatchSysfsM m) => Pin -> PinValue -> m () writePinValue p v = catchIOError (writeFile (pinValueFileName p) (pinValueToBS v)) mapIOError where - mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m () + mapIOError :: (ThrowSysfsM m) => IOError -> m () mapIOError e | isDoesNotExistError e = throwM $ NotExported p | isPermissionError e = throwM $ PermissionDenied p @@ -656,7 +635,7 @@ -- | 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 :: (ThrowSysfsM m) => Pin -> m Bool pinHasEdge p = do exported <- pinIsExported p if exported @@ -667,7 +646,7 @@ -- -- 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 :: (ThrowCatchSysfsM m) => Pin -> m SysfsEdge readPinEdge p = catchIOError (readFile (pinEdgeFileName p) >>= \case @@ -675,10 +654,10 @@ "rising\n" -> return Rising "falling\n" -> return Falling "both\n" -> return Both - x -> throwM $ UnexpectedEdge p (C8.unpack x)) + x -> throwM $ UnexpectedEdge p (decodeUtf8 x)) mapIOError where - mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m SysfsEdge + mapIOError :: (ThrowSysfsM m) => IOError -> m SysfsEdge mapIOError e | isDoesNotExistError e = do exported <- pinIsExported p @@ -692,13 +671,13 @@ -- -- 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 :: (CatchSysfsM m) => Pin -> SysfsEdge -> m () writePinEdge p v = catchIOError (writeFile (pinEdgeFileName p) (sysfsEdgeToBS v)) mapIOError where - mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m () + mapIOError :: (ThrowSysfsM m) => IOError -> m () mapIOError e | isDoesNotExistError e = do exported <- pinIsExported p @@ -710,29 +689,29 @@ | otherwise = throwM e -- | Read the pin's @active_low@ attribute. -readPinActiveLow :: (MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> m Bool +readPinActiveLow :: (ThrowCatchSysfsM 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)) + x -> throwM $ UnexpectedActiveLow p (decodeUtf8 x)) mapIOError where - mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m Bool + mapIOError :: (ThrowSysfsM 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 :: (CatchSysfsM m) => Pin -> Bool -> m () writePinActiveLow p v = catchIOError (writeFile (pinActiveLowFileName p) (activeLowToBS v)) mapIOError where - mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m () + mapIOError :: (ThrowSysfsM m) => IOError -> m () mapIOError e | isDoesNotExistError e = throwM $ NotExported p | isPermissionError e = throwM $ PermissionDenied p @@ -742,7 +721,7 @@ -- 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 :: (ThrowCatchSysfsM m) => m [Pin] availablePins = catchIOError (do sysfsEntries <- getDirectoryContents sysfsPath @@ -753,7 +732,7 @@ return $ sort $ concat gpioPins) mapIOError where - mapIOError :: (MonadSysfs m, MonadThrow m) => IOError -> m [Pin] + mapIOError :: (ThrowSysfsM m) => IOError -> m [Pin] mapIOError e | isDoesNotExistError e = throwM SysfsError | isPermissionError e = throwM SysfsPermissionDenied @@ -762,14 +741,14 @@ -- Helper actions that aren't exported. -- -readIntFromFile :: (MonadSysfs m, MonadThrow m) => FilePath -> m Int +readIntFromFile :: (ThrowSysfsM 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) + Nothing -> throwM $ UnexpectedContents f (decodeUtf8 contents) -pinRange :: (MonadSysfs m, MonadThrow m) => FilePath -> m [Pin] +pinRange :: (ThrowSysfsM m) => FilePath -> m [Pin] pinRange chipDir = do base <- readIntFromFile (chipDir "base") ngpio <- readIntFromFile (chipDir "ngpio") diff --git a/src/System/GPIO/Linux/Sysfs/Types.hs b/src/System/GPIO/Linux/Sysfs/Types.hs --- a/src/System/GPIO/Linux/Sysfs/Types.hs +++ b/src/System/GPIO/Linux/Sysfs/Types.hs @@ -24,9 +24,8 @@ , SysfsException(..) ) where -import Control.Monad.Catch (Exception(..)) -import Data.Data -import GHC.Generics +import Protolude +import Data.Data (Data) import Test.QuickCheck (Arbitrary(..), arbitraryBoundedEnum, genericShrink) import System.GPIO.Types @@ -133,21 +132,21 @@ -- ^ The pin does not have a @direction@ attribute | NoEdgeAttribute Pin -- ^ The pin does not have an @edge@ attribute - | UnexpectedDirection Pin String + | UnexpectedDirection Pin Text -- ^ An unexpected value was read from the pin's @direction@ -- attribute - | UnexpectedValue Pin String + | UnexpectedValue Pin Text -- ^ An unexpected value was read from the pin's @value@ -- attribute - | UnexpectedEdge Pin String + | UnexpectedEdge Pin Text -- ^ An unexpected value was read from the pin's @edge@ -- attribute - | UnexpectedActiveLow Pin String + | UnexpectedActiveLow Pin Text -- ^ An unexpected value was read from the pin's @active_low@ -- attribute - | UnexpectedContents FilePath String + | UnexpectedContents FilePath Text -- ^ An unexpected value was read from the specified file - | InternalError String + | InternalError Text -- ^ An internal error has occurred in the interpreter, something -- which should "never happen" and should be reported to the -- package maintainer diff --git a/src/System/GPIO/Linux/Sysfs/Util.hs b/src/System/GPIO/Linux/Sysfs/Util.hs --- a/src/System/GPIO/Linux/Sysfs/Util.hs +++ b/src/System/GPIO/Linux/Sysfs/Util.hs @@ -50,11 +50,10 @@ , bsToInt ) where -import Data.ByteString (ByteString) +import Protolude 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(..)) @@ -315,7 +314,7 @@ -- >>> intToBS 37 -- "37" intToBS :: Int -> ByteString -intToBS = LBS.toStrict . toLazyByteString . intDec +intToBS = toS . toLazyByteString . intDec -- | Convert a strict decimal ASCII 'ByteString' encoding of an -- integer to an 'Int' (maybe). If there are any extraneous trailing diff --git a/src/System/GPIO/Monad.hs b/src/System/GPIO/Monad.hs --- a/src/System/GPIO/Monad.hs +++ b/src/System/GPIO/Monad.hs @@ -11,12 +11,15 @@ -} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PackageImports #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Safe #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module System.GPIO.Monad ( -- * GPIO types @@ -33,6 +36,10 @@ , PinValue(..) , PinInterruptMode(..) + -- * Some convenient constraint synonyms for 'MonadGpio' signatures. + , MaskGpioM + , ThrowGpioM + -- * MonadGpio class , MonadGpio(..) , withPin @@ -96,14 +103,12 @@ , gpioExceptionFromException ) where -import Prelude () -import Prelude.Compat +import Protolude hiding (bracket) import Control.Monad.Catch (MonadMask, MonadThrow, bracket) import Control.Monad.Catch.Pure (CatchT) +import Control.Monad.Logger (LoggingT, NoLoggingT) 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.Class (MonadTrans) import Control.Monad.Trans.Identity (IdentityT) import "transformers" Control.Monad.Trans.List (ListT) import Control.Monad.Trans.Maybe (MaybeT) @@ -360,278 +365,102 @@ -- | 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 + default pins :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + m [Pin] + default pinCapabilities :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + Pin -> m PinCapabilities + default openPin :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + Pin -> m h + default closePin :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + h -> m () + default getPinDirection :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + h -> m PinDirection + default getPinInputMode :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + h -> m PinInputMode + default setPinInputMode :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + h -> PinInputMode -> m () + default getPinOutputMode :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + h -> m PinOutputMode + default setPinOutputMode :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + h -> PinOutputMode -> PinValue -> m () + default readPin :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + h -> m PinValue + default pollPin :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + h -> m PinValue + default pollPinTimeout :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + h -> Int -> m (Maybe PinValue) + default writePin :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + h -> PinValue -> m () + default togglePin :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + h -> m PinValue + default getPinInterruptMode :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + h -> m PinInterruptMode + default setPinInterruptMode :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + h -> PinInterruptMode -> m () + default getPinActiveLevel :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + h -> m PinActiveLevel + default setPinActiveLevel :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + h -> PinActiveLevel -> m () + default togglePinActiveLevel :: (MonadTrans t, MonadGpio h m', t m' ~ m) => + h -> m PinActiveLevel -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 + {-# INLINE pins #-} pinCapabilities = lift . pinCapabilities + {-# INLINE pinCapabilities #-} openPin = lift . openPin + {-# INLINE openPin #-} closePin = lift . closePin + {-# INLINE closePin #-} getPinDirection = lift . getPinDirection + {-# INLINE getPinDirection #-} getPinInputMode = lift . getPinInputMode + {-# INLINE getPinInputMode #-} setPinInputMode h mode = lift $ setPinInputMode h mode + {-# INLINE setPinInputMode #-} getPinOutputMode = lift . getPinOutputMode + {-# INLINE getPinOutputMode #-} setPinOutputMode h mode v = lift $ setPinOutputMode h mode v + {-# INLINE setPinOutputMode #-} readPin = lift . readPin + {-# INLINE readPin #-} pollPin = lift . readPin - pollPinTimeout h to = lift $ pollPinTimeout h to + {-# INLINE pollPin #-} + pollPinTimeout h timeout = lift $ pollPinTimeout h timeout + {-# INLINE pollPinTimeout #-} writePin h v = lift $ writePin h v + {-# INLINE writePin #-} togglePin = lift . togglePin + {-# INLINE togglePin #-} getPinInterruptMode = lift . getPinInterruptMode + {-# INLINE getPinInterruptMode #-} setPinInterruptMode h mode = lift $ setPinInterruptMode h mode + {-# INLINE setPinInterruptMode #-} getPinActiveLevel = lift . getPinActiveLevel + {-# INLINE getPinActiveLevel #-} setPinActiveLevel h v = lift $ setPinActiveLevel h v + {-# INLINE setPinActiveLevel #-} togglePinActiveLevel = lift . togglePinActiveLevel + {-# INLINE 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) => MonadGpio h (IdentityT m) +instance (MonadGpio h m) => MonadGpio h (ContT r m) +instance (MonadGpio h m) => MonadGpio h (CatchT m) +instance (MonadGpio h m) => MonadGpio h (ExceptT e m) +instance (MonadGpio h m) => MonadGpio h (ListT m) +instance (MonadGpio h m) => MonadGpio h (MaybeT m) +instance (MonadGpio h m) => MonadGpio h (ReaderT r m) +instance (MonadGpio h m, Monoid w) => MonadGpio h (LazyRWS.RWST r w s m) +instance (MonadGpio h m, Monoid w) => MonadGpio h (StrictRWS.RWST r w s m) +instance (MonadGpio h m) => MonadGpio h (LazyState.StateT s m) +instance (MonadGpio h m) => MonadGpio h (StrictState.StateT s m) +instance (MonadGpio h m, Monoid w) => MonadGpio h (LazyWriter.WriterT w m) +instance (MonadGpio h m, Monoid w) => MonadGpio h (StrictWriter.WriterT w m) +instance (MonadGpio h m) => MonadGpio h (LoggingT m) +instance (MonadGpio h m) => MonadGpio h (NoLoggingT m) -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 +type MaskGpioM h m = (MonadMask m, MonadGpio h m) +type ThrowGpioM h m = (MonadThrow m, MonadGpio h m) -- | Exception-safe pin management. -- @@ -641,7 +470,7 @@ -- 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 :: (MaskGpioM 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 @@ -665,7 +494,7 @@ -- -- 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 :: (MaskGpioM h m) => Pin -> PinInputMode -> Maybe PinActiveLevel -> (InputPin h -> m a) -> m a withInputPin p mode l action = withPin p $ \h -> do setPinInputMode h mode @@ -719,7 +548,7 @@ -- * 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 :: (MaskGpioM 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 @@ -748,7 +577,7 @@ getPinInputMode (_interruptHandle p) -- | Like 'getPinInterruptMode'. -getInterruptPinInterruptMode :: (MonadThrow m, MonadGpio h m) => InterruptPin h -> m PinInterruptMode +getInterruptPinInterruptMode :: (ThrowGpioM h m) => InterruptPin h -> m PinInterruptMode getInterruptPinInterruptMode p = getPinInterruptMode (_interruptHandle p) @@ -790,7 +619,7 @@ -- -- 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 :: (MaskGpioM 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 diff --git a/src/System/GPIO/Tutorial.hs b/src/System/GPIO/Tutorial.hs --- a/src/System/GPIO/Tutorial.hs +++ b/src/System/GPIO/Tutorial.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-unused-binds #-} module System.GPIO.Tutorial ( @@ -61,6 +62,7 @@ -- $copyright ) where +import Prelude import Control.Concurrent (threadDelay) import Control.Monad (forM_) import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch) @@ -86,6 +88,7 @@ -- $setup -- >>> :set -XFlexibleContexts +-- >>> :set -XOverloadedStrings -- >>> import System.GPIO.Monad {- $introduction diff --git a/src/System/GPIO/Types.hs b/src/System/GPIO/Types.hs --- a/src/System/GPIO/Types.hs +++ b/src/System/GPIO/Types.hs @@ -45,12 +45,10 @@ , gpioExceptionFromException ) where -import Control.Exception (Exception(..), SomeException) -import Data.Bits -import Data.Data -import Data.Ix -import Data.Set (Set) -import GHC.Generics +import Protolude +import Data.Data (Data) +import Data.Ix (Ix) +import qualified GHC.Show as GHC (Show(..)) import Test.QuickCheck (Arbitrary(..), arbitraryBoundedEnum, genericShrink) -- | A GPIO pin, identified by pin number. @@ -287,7 +285,7 @@ deriving Typeable instance Show SomeGpioException where - show (SomeGpioException e) = show e + show (SomeGpioException e) = GHC.show e instance Exception SomeGpioException diff --git a/stack-lts-2.yaml b/stack-lts-2.yaml --- a/stack-lts-2.yaml +++ b/stack-lts-2.yaml @@ -1,10 +1,23 @@ -require-stack-version: ">= 1.1.0" +require-stack-version: ! '>= 1.1.0' pvp-bounds: both resolver: lts-2.22 -packages: -- . extra-deps: +- base-compat-0.9.3 +- fail-4.9.0.0 +- mtl-2.2.1 +- mtl-compat-0.2.1.3 +- monad-logger-0.3.16 +- primitive-0.6.2.0 +- protolude-0.2 +- semigroups-0.18.2 +- transformers-0.4.3.0 +- transformers-compat-0.4.0.4 - unix-bytestring-0.3.7.3 +- void-0.7.2 +packages: +- . flags: hpio: test-hlint: false + semigroups: + bytestring-builder: false diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,6 +1,8 @@ require-stack-version: ">= 1.1.0" pvp-bounds: both -resolver: lts-8.20 +resolver: lts-9.6 +extra-deps: +- protolude-0.2 packages: - . flags: diff --git a/test/Main.hs b/test/Main.hs deleted file mode 100644 --- a/test/Main.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Main where - -import Test.Hspec -import Spec - -main :: IO () -main = hspec spec diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,1 +1,1 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/System/GPIO/Linux/Sysfs/LinuxBboneSpec.hs b/test/System/GPIO/Linux/Sysfs/LinuxBboneSpec.hs deleted file mode 100644 --- a/test/System/GPIO/Linux/Sysfs/LinuxBboneSpec.hs +++ /dev/null @@ -1,1144 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} - -module System.GPIO.Linux.Sysfs.LinuxBboneSpec (spec) where - -import Control.Concurrent (forkIO, threadDelay) -import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) -import Control.Monad (void) -import Control.Monad.Catch (throwM) -import Control.Monad.IO.Class (MonadIO, liftIO) -import System.Directory (doesDirectoryExist) -import System.GPIO.Linux.Sysfs (SysfsException(..), runSysfsGpioIO) -import System.GPIO.Monad (MonadGpio(..), withPin) -import System.GPIO.Types - (Pin(..), PinInputMode(..), PinOutputMode(..), PinActiveLevel(..), - PinDirection(..), PinInterruptMode(..), PinValue(..)) -import Test.Hspec - -isInvalidPinError :: SysfsException -> Bool -isInvalidPinError (InvalidPin _) = True -isInvalidPinError _ = False - -isNotExportedError :: SysfsException -> Bool -isNotExportedError (NotExported _) = True -isNotExportedError _ = False - -isUnsupportedInputMode :: SysfsException -> Bool -isUnsupportedInputMode (UnsupportedInputMode _ _) = True -isUnsupportedInputMode _ = False - -isUnsupportedOutputMode :: SysfsException -> Bool -isUnsupportedOutputMode (UnsupportedOutputMode _ _) = True -isUnsupportedOutputMode _ = False - -isPermissionDeniedError :: SysfsException -> Bool -isPermissionDeniedError (PermissionDenied _) = True -isPermissionDeniedError _ = False - -isInvalidOperationError :: SysfsException -> Bool -isInvalidOperationError (InvalidOperation _) = True -isInvalidOperationError _ = False - --- Note: it's not practical to test all exceptional cases, but we do --- our best. - --- Note: make sure the tests are always compiled, but only actually --- run on the proper platform. -spec :: Spec -spec = -#ifdef RUN_LINUX_BBONE_TESTS - runTests -#else - describe "Linux BeagleBone tests disabled on this platform" $ return () -#endif - --- NOTE: In order to run these tests properly, the following must be true: --- --- * They must be run on BeagleBone Black hardware running Linux. --- * You must have permission to export and unexport pins via the --- sysfs GPIO filesystem. --- * You must have permission to write pin attributes via the sysfs --- GPIO filesystem. --- * GPIO pins P9-15 (sysfs GPIO pin number 48) and P8-15 (sysfs GPIO --- pin number 47) must be jumpered together. - -testPin1 :: Pin -testPin1 = Pin 48 - -testPin2 :: Pin -testPin2 = Pin 47 - -invalidPin :: Pin -invalidPin = Pin 9000 - --- Note: tests which modify pin state have a slight delay between --- opening the pin and modifying any state. This is so that, if the --- user running the tests is not root and is using a udev action to --- change pin ownership (which is the only way at the time of writing --- to do that), the script has time to run. - -udevScriptWait :: MonadIO m => m () -udevScriptWait = liftIO $ threadDelay 500000 - -runTests :: Spec -runTests = - do - describe "runSysfsGpioIO" $ - do context "pins" $ - it "returns the full list of pins on the system" $ - runSysfsGpioIO pins `shouldReturn` (map Pin [0..127]) - context "openPin/closePin" $ - do it "exports/unexports the pin" $ - runSysfsGpioIO - (do h <- openPin testPin1 - exported <- liftIO $ doesDirectoryExist "/sys/class/gpio/gpio48" - closePin h - stillExported <- liftIO $ doesDirectoryExist "/sys/class/gpio/gpio48" - return (exported, stillExported)) - `shouldReturn` (True, False) - it "openPin doesn't complain if the pin is already exported" $ - runSysfsGpioIO - (withPin testPin1 $ \_ -> - do h <- openPin testPin1 - void $ getPinDirection h - return True) - `shouldReturn` True - it "openPin fails if the pin is invalid" $ - runSysfsGpioIO - (do h <- openPin invalidPin - dir <- getPinDirection h - return dir) - `shouldThrow` isInvalidPinError - it "closePin doesn't complain the pin is already unexported" $ - runSysfsGpioIO - (withPin testPin1 $ \_ -> - do h <- openPin testPin1 - closePin h - closePin h) - `shouldReturn` () - context "withPin" $ - do it "exports/unexports the pin" $ - do runSysfsGpioIO - (withPin testPin1 $ const $ - liftIO $ doesDirectoryExist "/sys/class/gpio/gpio48") - `shouldReturn` True - doesDirectoryExist "/sys/class/gpio/gpio48" `shouldReturn` False - it "unexports the pin upon exception" $ - do runSysfsGpioIO - (withPin testPin1 $ const $ - throwM $ userError "Foo") - `shouldThrow` anyIOException - doesDirectoryExist "/sys/class/gpio/gpio48" `shouldReturn` False - it "handles double-open and double-close gracefully" $ - do runSysfsGpioIO - (withPin testPin1 $ const $ - withPin testPin1 $ const $ - liftIO $ doesDirectoryExist "/sys/class/gpio/gpio48") - `shouldReturn` True - doesDirectoryExist "/sys/class/gpio/gpio48" `shouldReturn` False - it "fails if the pin is invalid" $ - do runSysfsGpioIO - (withPin invalidPin $ const $ - liftIO $ doesDirectoryExist "/sys/class/gpio/gpio9000") - `shouldThrow` isInvalidPinError - context "getPinDirection" $ - do it "gets the pin's direction" $ - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - dir1 <- getPinDirection h - setPinOutputMode h OutputDefault Low - dir2 <- getPinDirection h - setPinInputMode h InputDefault - dir3 <- getPinDirection h - return (dir1, dir2, dir3)) - `shouldReturn` (In, Out, In) - context "getPinInputMode" $ - do it "gets the pin's input mode" $ - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - getPinInputMode h) - `shouldReturn` InputDefault - it "fails when the pin is in output mode" $ - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinOutputMode h OutputDefault Low - getPinInputMode h) - `shouldThrow` isInvalidOperationError - context "setPinInputMode" $ - do it "sets the pin's input mode and direction" $ - do runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - m <- getPinInputMode h - d <- getPinDirection h - return (m,d)) - `shouldReturn` (InputDefault,In) - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinOutputMode h OutputDefault Low - setPinInputMode h InputDefault - m <- getPinInputMode h - d <- getPinDirection h - return (m,d)) - `shouldReturn` (InputDefault,In) - it "fails when the input mode is unsupported" $ - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputPullDown - getPinInputMode h) - `shouldThrow` isUnsupportedInputMode - context "getPinOutputMode" $ - do it "gets the pin's input mode" $ - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinOutputMode h OutputDefault Low - getPinOutputMode h) - `shouldReturn` OutputDefault - it "fails when the pin is in input mode" $ - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - getPinOutputMode h) - `shouldThrow` isInvalidOperationError - context "setPinOutputMode" $ - do it "sets the pin's output mode, direction, and value" $ - do runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinActiveLevel h ActiveHigh - setPinOutputMode h OutputDefault Low - v <- readPin h - m <- getPinOutputMode h - d <- getPinDirection h - return (v,m,d)) - `shouldReturn` (Low,OutputDefault,Out) - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinActiveLevel h ActiveHigh - setPinOutputMode h OutputDefault High - v <- readPin h - m <- getPinOutputMode h - d <- getPinDirection h - return (v,m,d)) - `shouldReturn` (High,OutputDefault,Out) - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveHigh - setPinInputMode h InputDefault - setPinOutputMode h OutputDefault High - v <- readPin h - m <- getPinOutputMode h - d <- getPinDirection h - return (v,m,d)) - `shouldReturn` (High,OutputDefault,Out) - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveHigh - setPinInputMode h InputDefault - setPinOutputMode h OutputDefault Low - v <- readPin h - m <- getPinOutputMode h - d <- getPinDirection h - return (v,m,d)) - `shouldReturn` (Low,OutputDefault,Out) - it "respects the pin's active level" $ - do runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinActiveLevel h ActiveLow - setPinOutputMode h OutputDefault Low - setPinActiveLevel h ActiveHigh - v <- readPin h - m <- getPinOutputMode h - d <- getPinDirection h - return (v,m,d)) - `shouldReturn` (High,OutputDefault,Out) - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinActiveLevel h ActiveLow - setPinOutputMode h OutputDefault High - setPinActiveLevel h ActiveHigh - v <- readPin h - m <- getPinOutputMode h - d <- getPinDirection h - return (v,m,d)) - `shouldReturn` (Low,OutputDefault,Out) - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveLow - setPinInputMode h InputDefault - setPinOutputMode h OutputDefault High - setPinActiveLevel h ActiveHigh - v <- readPin h - m <- getPinOutputMode h - d <- getPinDirection h - return (v,m,d)) - `shouldReturn` (Low,OutputDefault,Out) - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveLow - setPinInputMode h InputDefault - setPinOutputMode h OutputDefault Low - setPinActiveLevel h ActiveHigh - v <- readPin h - m <- getPinOutputMode h - d <- getPinDirection h - return (v,m,d)) - `shouldReturn` (High,OutputDefault,Out) - it "can set the pin's direction to 'Out' when it's configured for edge-triggered reads" $ - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinInterruptMode h RisingEdge - setPinOutputMode h OutputDefault Low - setPinInputMode h InputDefault - setPinInterruptMode h FallingEdge - setPinOutputMode h OutputDefault High - setPinInputMode h InputDefault - setPinInterruptMode h Level - setPinOutputMode h OutputDefault Low - return True) - `shouldReturn` True - it "fails when the output mode is unsupported" $ - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinOutputMode h OutputOpenSourcePullDown Low - getPinInputMode h) - `shouldThrow` isUnsupportedOutputMode - context "getPinActiveLevel/setPinActiveLevel" $ - it "gets and sets the pin's active level" $ - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveLow - level1 <- getPinActiveLevel h - setPinActiveLevel h ActiveHigh - level2 <- getPinActiveLevel h - setPinActiveLevel h ActiveLow - level3 <- getPinActiveLevel h - return (level1, level2, level3)) - `shouldReturn` (ActiveLow, ActiveHigh, ActiveLow) - context "togglePinActiveLevel" $ - it "toggles the pin's active level" $ - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveHigh - level1 <- togglePinActiveLevel h - level2 <- togglePinActiveLevel h - level3 <- togglePinActiveLevel h - return (level1, level2, level3)) - `shouldReturn` (ActiveLow, ActiveHigh, ActiveLow) - context "readPin/writePin" $ - -- Note: if these tests fail, you might not have hooked pin - -- P9-15 up to pin P8-15! - do it "reads and writes the pin's value" $ - runSysfsGpioIO - (withPin testPin1 $ \h1 -> - withPin testPin2 $ \h2 -> - do udevScriptWait - setPinInputMode h1 InputDefault - setPinActiveLevel h1 ActiveHigh - setPinActiveLevel h2 ActiveHigh - setPinOutputMode h2 OutputDefault High - -- give the pin time to settle - liftIO $ threadDelay 250000 - val1 <- readPin h1 - writePin h2 Low - liftIO $ threadDelay 250000 - val2 <- readPin h1 - writePin h2 High - liftIO $ threadDelay 250000 - val3 <- readPin h1 - return (val1, val2, val3)) - `shouldReturn` (High, Low, High) - it "readPin obeys the pin's active level" $ - runSysfsGpioIO - (withPin testPin1 $ \h1 -> - withPin testPin2 $ \h2 -> - do udevScriptWait - setPinInputMode h1 InputDefault - setPinActiveLevel h1 ActiveLow - setPinActiveLevel h2 ActiveHigh - setPinOutputMode h2 OutputDefault High - -- give the pin time to settle - liftIO $ threadDelay 250000 - val1 <- readPin h1 - writePin h2 Low - liftIO $ threadDelay 250000 - val2 <- readPin h1 - writePin h2 High - liftIO $ threadDelay 250000 - val3 <- readPin h1 - return (val1, val2, val3)) - `shouldReturn` (Low, High, Low) - it "readPin works on output pins" $ - runSysfsGpioIO - (withPin testPin2 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveHigh - setPinOutputMode h OutputDefault High - liftIO $ threadDelay 250000 - val1 <- readPin h - writePin h Low - liftIO $ threadDelay 250000 - val2 <- readPin h - writePin h High - liftIO $ threadDelay 250000 - val3 <- readPin h - return (val1, val2, val3)) - `shouldReturn` (High, Low, High) - it "readPin works on output pins (active-low)" $ - runSysfsGpioIO - (withPin testPin2 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveLow - setPinOutputMode h OutputDefault High - liftIO $ threadDelay 250000 - val1 <- readPin h - writePin h Low - liftIO $ threadDelay 250000 - val2 <- readPin h - writePin h High - liftIO $ threadDelay 250000 - val3 <- readPin h - return (val1, val2, val3)) - `shouldReturn` (High, Low, High) - it "writePin obeys the pin's active level" $ - runSysfsGpioIO - (withPin testPin1 $ \h1 -> - withPin testPin2 $ \h2 -> - do udevScriptWait - setPinInputMode h1 InputDefault - setPinActiveLevel h1 ActiveHigh - setPinActiveLevel h2 ActiveLow - setPinOutputMode h2 OutputDefault High - -- give the pin time to settle - liftIO $ threadDelay 250000 - val1 <- readPin h1 - writePin h2 Low - liftIO $ threadDelay 250000 - val2 <- readPin h1 - writePin h2 High - liftIO $ threadDelay 250000 - val3 <- readPin h1 - return (val1, val2, val3)) - `shouldReturn` (Low, High, Low) - it "fails if the pin is configured for input" $ - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - writePin h High) - `shouldThrow` isPermissionDeniedError - context "togglePin" $ - -- Note: if these tests fail, you might not have hooked pin - -- P9-15 up to pin P8-15! - do it "toggles the pin's value and returns the previous value" $ - runSysfsGpioIO - (withPin testPin1 $ \h1 -> - withPin testPin2 $ \h2 -> - do udevScriptWait - setPinInputMode h1 InputDefault - setPinActiveLevel h1 ActiveHigh - setPinActiveLevel h2 ActiveHigh - setPinOutputMode h2 OutputDefault Low - h2_val1 <- togglePin h2 - -- give the pin time to settle - liftIO $ threadDelay 250000 - h1_val1 <- readPin h1 - h2_val2 <- togglePin h2 - liftIO $ threadDelay 250000 - h1_val2 <- readPin h1 - h2_val3 <- togglePin h2 - liftIO $ threadDelay 250000 - h1_val3 <- readPin h1 - return (h2_val1, h1_val1, h2_val2, h1_val2, h2_val3, h1_val3)) - `shouldReturn` (High, High, Low, Low, High, High) - it "togglePin obeys the pin's active level" $ - runSysfsGpioIO - (withPin testPin1 $ \h1 -> - withPin testPin2 $ \h2 -> - do udevScriptWait - setPinInputMode h1 InputDefault - setPinActiveLevel h1 ActiveHigh - setPinActiveLevel h2 ActiveLow - setPinOutputMode h2 OutputDefault Low - h2_val1 <- togglePin h2 - -- give the pin time to settle - liftIO $ threadDelay 250000 - h1_val1 <- readPin h1 - h2_val2 <- togglePin h2 - liftIO $ threadDelay 250000 - h1_val2 <- readPin h1 - h2_val3 <- togglePin h2 - liftIO $ threadDelay 250000 - h1_val3 <- readPin h1 - return (h2_val1, h1_val1, h2_val2, h1_val2, h2_val3, h1_val3)) - `shouldReturn` (High, Low, Low, High, High, Low) - it "fails if the pin is configured for input" $ - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - void $ togglePin h) - `shouldThrow` isPermissionDeniedError - context "getPinInterruptMode/setPinInterruptMode" $ - do it "gets and sets the pin's interrupt mode" $ - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinInterruptMode h RisingEdge - trigger1 <- getPinInterruptMode h - setPinInterruptMode h FallingEdge - trigger2 <- getPinInterruptMode h - setPinInterruptMode h Level - trigger3 <- getPinInterruptMode h - setPinInterruptMode h Disabled - trigger4 <- getPinInterruptMode h - return (trigger1, trigger2, trigger3, trigger4)) - `shouldReturn` (RisingEdge, FallingEdge, Level, Disabled) - it "setPinInterruptMode should fail on an output pin" $ - runSysfsGpioIO - (withPin testPin2 $ \h -> - do udevScriptWait - setPinOutputMode h OutputDefault Low - setPinInterruptMode h Level) - `shouldThrow` isInvalidOperationError - context "pollPin" $ - -- Note: if these tests fail, you might not have hooked pin - -- P9-15 up to pin P8-15! - do it "pollPin waits for rising edge" $ - do mvar <- liftIO $ newEmptyMVar - void $ liftIO $ forkIO $ - do runSysfsGpioIO $ - withPin testPin2 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveHigh - setPinOutputMode h OutputDefault High - liftIO $ void $ takeMVar mvar - liftIO $ threadDelay 500000 - void $ togglePin h - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - putMVar mvar () -- synchronize finish - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinActiveLevel h ActiveHigh - setPinInterruptMode h RisingEdge - liftIO $ putMVar mvar () - val1 <- pollPin h - val2 <- pollPin h - liftIO $ void $ takeMVar mvar -- synchronize finish - return (val1, val2)) - `shouldReturn` (High, High) - it "pollPin waits for falling edge" $ - do mvar <- liftIO $ newEmptyMVar - void $ liftIO $ forkIO $ - do runSysfsGpioIO $ - withPin testPin2 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveHigh - setPinOutputMode h OutputDefault Low - liftIO $ void $ takeMVar mvar - liftIO $ threadDelay 500000 - void $ togglePin h - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - putMVar mvar () -- synchronize finish - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinActiveLevel h ActiveHigh - setPinInterruptMode h FallingEdge - liftIO $ putMVar mvar () - val1 <- pollPin h - val2 <- pollPin h - liftIO $ void $ takeMVar mvar -- synchronize finish - return (val1, val2)) - `shouldReturn` (Low, Low) - it "pollPin waits for level changes" $ - do mvar <- liftIO $ newEmptyMVar - void $ liftIO $ forkIO $ - do runSysfsGpioIO $ - withPin testPin2 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveHigh - setPinOutputMode h OutputDefault High - liftIO $ void $ takeMVar mvar - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - putMVar mvar () -- synchronize finish - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinActiveLevel h ActiveHigh - setPinInterruptMode h Level - liftIO $ putMVar mvar () - val1 <- pollPin h - val2 <- pollPin h - val3 <- pollPin h - val4 <- pollPin h - liftIO $ void $ takeMVar mvar -- synchronize finish - return (val1, val2, val3, val4)) - `shouldReturn` (Low, High, Low, High) - it "pollPin can be disabled" $ - do mvar <- liftIO $ newEmptyMVar - runSysfsGpioIO - (withPin testPin1 $ \inPin -> - withPin testPin2 $ \outPin -> - do udevScriptWait - setPinInputMode inPin InputDefault - setPinActiveLevel inPin ActiveHigh - setPinInterruptMode inPin Disabled - setPinActiveLevel outPin ActiveHigh - setPinOutputMode outPin OutputDefault Low - void $ liftIO $ forkIO $ - do runSysfsGpioIO $ - do liftIO $ void $ takeMVar mvar - liftIO $ threadDelay 500000 - void $ togglePin outPin -- ignored - liftIO $ threadDelay 500000 - setPinInterruptMode inPin Level - void $ togglePin outPin -- trigger - putMVar mvar () -- synchronize finish - liftIO $ putMVar mvar () - val <- pollPin inPin - liftIO $ void $ takeMVar mvar -- synchronize finish - return val) - `shouldReturn` Low - context "pollPin with active-low logic" $ - -- Note: if these tests fail, you might not have hooked pin - -- P9-15 up to pin P8-15! - do it "pollPin waits for (active-low) rising edge" $ - do mvar <- liftIO $ newEmptyMVar - void $ liftIO $ forkIO $ - do runSysfsGpioIO $ - withPin testPin2 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveHigh - setPinOutputMode h OutputDefault Low - liftIO $ void $ takeMVar mvar - liftIO $ threadDelay 500000 - void $ togglePin h - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - putMVar mvar () -- synchronize finish - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinActiveLevel h ActiveLow - setPinInterruptMode h RisingEdge - liftIO $ putMVar mvar () - val1 <- pollPin h - val2 <- pollPin h - liftIO $ void $ takeMVar mvar -- synchronize finish - return (val1, val2)) - `shouldReturn` (High, High) - it "pollPin waits for (active-low) falling edge" $ - do mvar <- liftIO $ newEmptyMVar - void $ liftIO $ forkIO $ - do runSysfsGpioIO $ - withPin testPin2 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveHigh - setPinOutputMode h OutputDefault High - liftIO $ void $ takeMVar mvar - liftIO $ threadDelay 500000 - void $ togglePin h - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - putMVar mvar () -- synchronize finish - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinActiveLevel h ActiveLow - setPinInterruptMode h FallingEdge - liftIO $ putMVar mvar () - val1 <- pollPin h - val2 <- pollPin h - liftIO $ void $ takeMVar mvar -- synchronize finish - return (val1, val2)) - `shouldReturn` (Low, Low) - it "pollPin waits for level changes" $ - do mvar <- liftIO $ newEmptyMVar - void $ liftIO $ forkIO $ - do runSysfsGpioIO $ - withPin testPin2 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveHigh - setPinOutputMode h OutputDefault Low - liftIO $ void $ takeMVar mvar - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - putMVar mvar () -- synchronize finish - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinActiveLevel h ActiveLow - setPinInterruptMode h Level - liftIO $ putMVar mvar () - val1 <- pollPin h - val2 <- pollPin h - val3 <- pollPin h - val4 <- pollPin h - liftIO $ void $ takeMVar mvar -- synchronize finish - return (val1, val2, val3, val4)) - `shouldReturn` (Low, High, Low, High) - it "pollPin can be disabled" $ - do mvar <- liftIO $ newEmptyMVar - runSysfsGpioIO - (withPin testPin1 $ \inPin -> - withPin testPin2 $ \outPin -> - do udevScriptWait - setPinInputMode inPin InputDefault - setPinActiveLevel inPin ActiveLow - setPinInterruptMode inPin Disabled - setPinActiveLevel outPin ActiveHigh - setPinOutputMode outPin OutputDefault Low - void $ liftIO $ forkIO $ - do runSysfsGpioIO $ - do liftIO $ void $ takeMVar mvar - liftIO $ threadDelay 500000 - void $ togglePin outPin -- ignored - liftIO $ threadDelay 500000 - setPinInterruptMode inPin Level - void $ togglePin outPin -- trigger - putMVar mvar () -- synchronize finish - liftIO $ putMVar mvar () - val <- pollPin inPin - liftIO $ void $ takeMVar mvar -- synchronize finish - return val) - `shouldReturn` High - context "pollPinTimeout" $ - -- Note: if these tests fail, you might not have hooked pin - -- P9-15 up to pin P8-15! - do it "pollPinTimeout waits for rising edge" $ - do mvar <- liftIO $ newEmptyMVar - void $ liftIO $ forkIO $ - do runSysfsGpioIO $ - withPin testPin2 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveHigh - setPinOutputMode h OutputDefault High - liftIO $ void $ takeMVar mvar - liftIO $ threadDelay 500000 - void $ togglePin h - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - putMVar mvar () -- synchronize finish - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinActiveLevel h ActiveHigh - setPinInterruptMode h RisingEdge - liftIO $ putMVar mvar () - val1 <- pollPinTimeout h 10000000 - val2 <- pollPinTimeout h 10000000 - liftIO $ void $ takeMVar mvar -- synchronize finish - return (val1, val2)) - `shouldReturn` (Just High, Just High) - it "pollPinTimeout waits for falling edge" $ - do mvar <- liftIO $ newEmptyMVar - void $ liftIO $ forkIO $ - do runSysfsGpioIO $ - withPin testPin2 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveHigh - setPinOutputMode h OutputDefault Low - liftIO $ void $ takeMVar mvar - liftIO $ threadDelay 500000 - void $ togglePin h - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - putMVar mvar () -- synchronize finish - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinActiveLevel h ActiveHigh - setPinInterruptMode h FallingEdge - liftIO $ putMVar mvar () - val1 <- pollPinTimeout h 10000000 - val2 <- pollPinTimeout h 10000000 - liftIO $ void $ takeMVar mvar -- synchronize finish - return (val1, val2)) - `shouldReturn` (Just Low, Just Low) - it "pollPinTimeout waits for level changes" $ - do mvar <- liftIO $ newEmptyMVar - void $ liftIO $ forkIO $ - do runSysfsGpioIO $ - withPin testPin2 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveHigh - setPinOutputMode h OutputDefault High - liftIO $ void $ takeMVar mvar - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - putMVar mvar () -- synchronize finish - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinActiveLevel h ActiveHigh - setPinInterruptMode h Level - liftIO $ putMVar mvar () - val1 <- pollPinTimeout h 10000000 - val2 <- pollPinTimeout h 10000000 - val3 <- pollPinTimeout h 10000000 - val4 <- pollPinTimeout h 10000000 - liftIO $ void $ takeMVar mvar -- synchronize finish - return (val1, val2, val3, val4)) - `shouldReturn` (Just Low, Just High, Just Low, Just High) - it "pollPinTimeout can be disabled" $ - do mvar <- liftIO $ newEmptyMVar - runSysfsGpioIO - (withPin testPin1 $ \inPin -> - withPin testPin2 $ \outPin -> - do udevScriptWait - setPinInputMode inPin InputDefault - setPinActiveLevel inPin ActiveHigh - setPinInterruptMode inPin Disabled - setPinActiveLevel outPin ActiveHigh - setPinOutputMode outPin OutputDefault Low - void $ liftIO $ forkIO $ - do runSysfsGpioIO $ - do liftIO $ void $ takeMVar mvar - liftIO $ threadDelay 500000 - void $ togglePin outPin -- ignored - liftIO $ threadDelay 500000 - setPinInterruptMode inPin Level - void $ togglePin outPin -- trigger - putMVar mvar () -- synchronize finish - liftIO $ putMVar mvar () - val <- pollPinTimeout inPin 10000000 - liftIO $ void $ takeMVar mvar -- synchronize finish - return val) - `shouldReturn` Just Low - it "pollPinTimeout actually times out" $ - do mvar <- liftIO $ newEmptyMVar - runSysfsGpioIO - (withPin testPin1 $ \inPin -> - withPin testPin2 $ \outPin -> - do udevScriptWait - setPinInputMode inPin InputDefault - setPinActiveLevel inPin ActiveHigh - setPinInterruptMode inPin Disabled - setPinActiveLevel outPin ActiveHigh - setPinOutputMode outPin OutputDefault Low - void $ liftIO $ forkIO $ - do runSysfsGpioIO $ - do liftIO $ void $ takeMVar mvar - liftIO $ threadDelay 500000 - void $ togglePin outPin -- ignored - liftIO $ threadDelay 500000 - void $ togglePin outPin -- ignored - putMVar mvar () -- synchronize finish - liftIO $ putMVar mvar () - val <- pollPinTimeout inPin 1000000 - liftIO $ void $ takeMVar mvar -- synchronize finish - return val) - `shouldReturn` Nothing - it "pollPinTimeout times out on output pins" $ - do runSysfsGpioIO - (withPin testPin2 $ \outPin -> - do udevScriptWait - setPinActiveLevel outPin ActiveHigh - setPinOutputMode outPin OutputDefault Low - val <- pollPinTimeout outPin 1000000 - return val) - `shouldReturn` Nothing - context "pollPinTimeout with active-low logic" $ - -- Note: if these tests fail, you might not have hooked pin - -- P9-15 up to pin P8-15! - do it "pollPinTimeout waits for (active-low) rising edge" $ - do mvar <- liftIO $ newEmptyMVar - void $ liftIO $ forkIO $ - do runSysfsGpioIO $ - withPin testPin2 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveHigh - setPinOutputMode h OutputDefault Low - liftIO $ void $ takeMVar mvar - liftIO $ threadDelay 500000 - void $ togglePin h - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - putMVar mvar () -- synchronize finish - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinActiveLevel h ActiveLow - setPinInterruptMode h RisingEdge - liftIO $ putMVar mvar () - val1 <- pollPinTimeout h 10000000 - val2 <- pollPinTimeout h 10000000 - liftIO $ void $ takeMVar mvar -- synchronize finish - return (val1, val2)) - `shouldReturn` (Just High, Just High) - it "pollPinTimeout waits for (active-low) falling edge" $ - do mvar <- liftIO $ newEmptyMVar - void $ liftIO $ forkIO $ - do runSysfsGpioIO $ - withPin testPin2 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveHigh - setPinOutputMode h OutputDefault High - liftIO $ void $ takeMVar mvar - liftIO $ threadDelay 500000 - void $ togglePin h - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - putMVar mvar () -- synchronize finish - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinActiveLevel h ActiveLow - setPinInterruptMode h FallingEdge - liftIO $ putMVar mvar () - val1 <- pollPinTimeout h 10000000 - val2 <- pollPinTimeout h 10000000 - liftIO $ void $ takeMVar mvar -- synchronize finish - return (val1, val2)) - `shouldReturn` (Just Low, Just Low) - it "pollPinTimeout waits for level changes" $ - do mvar <- liftIO $ newEmptyMVar - void $ liftIO $ forkIO $ - do runSysfsGpioIO $ - withPin testPin2 $ \h -> - do udevScriptWait - setPinActiveLevel h ActiveHigh - setPinOutputMode h OutputDefault Low - liftIO $ void $ takeMVar mvar - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - liftIO $ threadDelay 500000 - void $ togglePin h -- trigger - putMVar mvar () -- synchronize finish - runSysfsGpioIO - (withPin testPin1 $ \h -> - do udevScriptWait - setPinInputMode h InputDefault - setPinActiveLevel h ActiveLow - setPinInterruptMode h Level - liftIO $ putMVar mvar () - val1 <- pollPinTimeout h 10000000 - val2 <- pollPinTimeout h 10000000 - val3 <- pollPinTimeout h 10000000 - val4 <- pollPinTimeout h 10000000 - liftIO $ void $ takeMVar mvar -- synchronize finish - return (val1, val2, val3, val4)) - `shouldReturn` (Just Low, Just High, Just Low, Just High) - it "pollPinTimeout can be disabled" $ - do mvar <- liftIO $ newEmptyMVar - runSysfsGpioIO - (withPin testPin1 $ \inPin -> - withPin testPin2 $ \outPin -> - do udevScriptWait - setPinInputMode inPin InputDefault - setPinActiveLevel inPin ActiveLow - setPinInterruptMode inPin Disabled - setPinActiveLevel outPin ActiveHigh - setPinOutputMode outPin OutputDefault Low - void $ liftIO $ forkIO $ - do runSysfsGpioIO $ - do liftIO $ void $ takeMVar mvar - liftIO $ threadDelay 500000 - void $ togglePin outPin -- ignored - liftIO $ threadDelay 500000 - setPinInterruptMode inPin Level - void $ togglePin outPin -- trigger - putMVar mvar () -- synchronize finish - liftIO $ putMVar mvar () - val <- pollPinTimeout inPin 10000000 - liftIO $ void $ takeMVar mvar -- synchronize finish - return val) - `shouldReturn` Just High - context "Various NotExported exceptions" $ - do it "getPinDirection" $ - runSysfsGpioIO - (do h <- openPin testPin1 - closePin h - v <- getPinDirection h - return v) - `shouldThrow` isNotExportedError - it "getPinInputMode" $ - runSysfsGpioIO - (do h <- openPin testPin1 - closePin h - getPinInputMode h) - `shouldThrow` isNotExportedError - it "setPinInputMode" $ - runSysfsGpioIO - (do h <- openPin testPin1 - closePin h - setPinInputMode h InputDefault) - `shouldThrow` isNotExportedError - it "getPinOutputMode" $ - runSysfsGpioIO - (do h <- openPin testPin1 - closePin h - getPinOutputMode h) - `shouldThrow` isNotExportedError - it "setPinOutputMode" $ - runSysfsGpioIO - (do h <- openPin testPin1 - closePin h - setPinOutputMode h OutputDefault Low) - `shouldThrow` isNotExportedError - it "getPinInterruptMode" $ - runSysfsGpioIO - (do h <- openPin testPin1 - closePin h - v <- getPinInterruptMode h - return v) - `shouldThrow` isNotExportedError - it "setPinInterruptMode" $ - runSysfsGpioIO - (do h <- openPin testPin1 - closePin h - setPinInterruptMode h RisingEdge) - `shouldThrow` isNotExportedError - it "getPinActiveLevel" $ - runSysfsGpioIO - (do h <- openPin testPin1 - closePin h - v <- getPinActiveLevel h - return v) - `shouldThrow` isNotExportedError - it "setPinActiveLevel" $ - runSysfsGpioIO - (do h <- openPin testPin1 - closePin h - setPinActiveLevel h ActiveHigh) - `shouldThrow` isNotExportedError - it "toggleActiveLevel" $ - runSysfsGpioIO - (do h <- openPin testPin1 - closePin h - v <- togglePinActiveLevel h - return v) - `shouldThrow` isNotExportedError - it "readPin" $ - runSysfsGpioIO - (do h <- openPin testPin1 - closePin h - v <- readPin h - return v) - `shouldThrow` isNotExportedError - it "pollPin" $ - runSysfsGpioIO - (do h <- openPin testPin1 - closePin h - v <- pollPin h - return v) - `shouldThrow` isNotExportedError - it "pollPinTimeout" $ - runSysfsGpioIO - (do h <- openPin testPin1 - closePin h - v <- pollPinTimeout h 100000 - return v) - `shouldThrow` isNotExportedError - it "writePin" $ - runSysfsGpioIO - (do h <- openPin testPin1 - closePin h - writePin h High) - `shouldThrow` isNotExportedError - it "togglePin" $ - runSysfsGpioIO - (do h <- openPin testPin1 - closePin h - v <- togglePin h - return v) - `shouldThrow` isNotExportedError diff --git a/test/System/GPIO/Linux/Sysfs/MockInternalSpec.hs b/test/System/GPIO/Linux/Sysfs/MockInternalSpec.hs deleted file mode 100644 --- a/test/System/GPIO/Linux/Sysfs/MockInternalSpec.hs +++ /dev/null @@ -1,328 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-incomplete-uni-patterns #-} -{-# LANGUAGE OverloadedStrings #-} - -module System.GPIO.Linux.Sysfs.MockInternalSpec (spec) where - -import GHC.IO.Exception (IOErrorType(..)) -import System.GPIO.Linux.Sysfs.Mock.Internal -import System.IO.Error (ioeGetErrorType, isAlreadyExistsError, isDoesNotExistError) -import Test.Hspec - -isInvalidArgumentErrorType :: IOErrorType -> Bool -isInvalidArgumentErrorType InvalidArgument = True -isInvalidArgumentErrorType _ = False - -isInvalidArgumentError :: IOError -> Bool -isInvalidArgumentError = isInvalidArgumentErrorType . ioeGetErrorType - -isInappropriateTypeErrorType :: IOErrorType -> Bool -isInappropriateTypeErrorType InappropriateType = True -isInappropriateTypeErrorType _ = False - -isInappropriateTypeError :: IOError -> Bool -isInappropriateTypeError = isInappropriateTypeErrorType . ioeGetErrorType - -sysfsRoot :: Directory -sysfsRoot = - directory "/" - [] - [directory "sys" - [] - [directory "class" - [] - [directory "gpio" - [File "export" Export - ,File "unexport" Unexport] - []]]] - -parentName :: MockFSCrumb -> Name -parentName = _dirNodeName . _node - -spec :: Spec -spec = - let sysfsRootZ = MockFSZipper sysfsRoot [] - in - do describe "cd" $ do - - context "relative paths" $ do - - it "can traverse downwards one directory at a time" $ - do let Right z1@(MockFSZipper dir1 (crumb1:_)) = cd "sys" sysfsRootZ - dirName dir1 `shouldBe` "sys" - parentName crumb1 `shouldBe` "/" - let Right z2@(MockFSZipper dir2 (crumb2:_)) = cd "class" z1 - dirName dir2 `shouldBe` "class" - parentName crumb2 `shouldBe` "sys" - let Right (MockFSZipper dir3 (crumb3:_)) = cd "gpio" z2 - dirName dir3 `shouldBe` "gpio" - parentName crumb3 `shouldBe` "class" - - it "can traverse downwards multiple directories at a time" $ - do let Right (MockFSZipper dir1 (crumb1:_)) = cd "sys/class/gpio" sysfsRootZ - dirName dir1 `shouldBe` "gpio" - parentName crumb1 `shouldBe` "class" - - it "fails when changing to a non-existent child" $ - do let Left result1 = cd "foobar" sysfsRootZ - isDoesNotExistError result1 `shouldBe` True - let Left result2 = (cd "sys/class" sysfsRootZ >>= cd "baz" ) - isDoesNotExistError result2 `shouldBe` True - - it "fails when changing to a non-existent grandchild" $ - do let Left result = cd "sys/class/foobar" sysfsRootZ - isDoesNotExistError result `shouldBe` True - - it "fails when changing to a file name rather than a directory name" $ - do let Left result1 = (cd "sys/class/gpio" sysfsRootZ >>= cd "export") - isInappropriateTypeError result1 `shouldBe` True - let Left result2 = (cd "sys/class/gpio" sysfsRootZ >>= cd "export/foobar") - isInappropriateTypeError result2 `shouldBe` True - let Left result3 = cd "sys/class/gpio/unexport" sysfsRootZ - isInappropriateTypeError result3 `shouldBe` True - let Left result4 = cd "sys/class/gpio/unexport/baz" sysfsRootZ - isInappropriateTypeError result4 `shouldBe` True - - it "'.' in paths" $ - do cd "sys/." sysfsRootZ `shouldBe` cd "sys" sysfsRootZ - cd "sys/./class" sysfsRootZ `shouldBe` cd "sys/class" sysfsRootZ - - it "'..' in paths" $ - do cd "sys/.." sysfsRootZ `shouldBe` Right sysfsRootZ - cd "sys/class/../class" sysfsRootZ `shouldBe` cd "sys/class" sysfsRootZ - cd "sys/class/gpio/../../class" sysfsRootZ `shouldBe` cd "sys/../sys/class/../class/gpio/.." sysfsRootZ - cd "sys/class/gpio/../../.." sysfsRootZ `shouldBe` Right sysfsRootZ - - it "'..' beyond root clamps to root" $ - do cd "sys/class/../../../.." sysfsRootZ `shouldBe` Right sysfsRootZ - cd "../.." sysfsRootZ `shouldBe` Right sysfsRootZ - - context "absolute paths" $ do - it "can traverse downwards one directory at a time" $ - do let Right z1@(MockFSZipper dir1 (crumb1:_)) = cd "/sys" sysfsRootZ - dirName dir1 `shouldBe` "sys" - parentName crumb1 `shouldBe` "/" - let Right z2@(MockFSZipper dir2 (crumb2:_)) = cd "class" z1 - dirName dir2 `shouldBe` "class" - parentName crumb2 `shouldBe` "sys" - let Right (MockFSZipper dir3 (crumb3:_)) = cd "gpio" z2 - dirName dir3 `shouldBe` "gpio" - parentName crumb3 `shouldBe` "class" - it "can traverse downwards multiple directories at a time" $ - do let Right (MockFSZipper dir1 (crumb1:_)) = cd "/sys/class/gpio" sysfsRootZ - dirName dir1 `shouldBe` "gpio" - parentName crumb1 `shouldBe` "class" - it "fails when changing to a non-existent child" $ - do let Left result = cd "/foobar" sysfsRootZ - isDoesNotExistError result `shouldBe` True - it "fails when changing to a non-existent grandchild" $ - do let Left result = cd "/sys/class/foobar" sysfsRootZ - isDoesNotExistError result `shouldBe` True - it "fails when changing to a file name rather than a directory name" $ - do let Left result1 = cd "/sys/class/gpio/export" sysfsRootZ - isInappropriateTypeError result1 `shouldBe` True - let Left result2 = cd "/sys/class/gpio/unexport/baz" sysfsRootZ - isInappropriateTypeError result2 `shouldBe` True - - it "cd / is root" $ - cd "/" sysfsRootZ `shouldBe` Right sysfsRootZ - - it "cd / from deeper starts at root" $ do - (cd "/sys/class/gpio" sysfsRootZ >>= cd "/") `shouldBe` Right sysfsRootZ - (cd "/sys/class/gpio" sysfsRootZ >>= cd "/sys/class") `shouldBe` cd "/sys/class" sysfsRootZ - - it "'.' in paths" $ - do cd "/sys/." sysfsRootZ `shouldBe` cd "/sys" sysfsRootZ - cd "/sys/./class" sysfsRootZ `shouldBe` cd "/sys/class" sysfsRootZ - it "'..' in paths" $ - do cd "/sys/.." sysfsRootZ `shouldBe` Right sysfsRootZ - cd "/sys/class/../class" sysfsRootZ `shouldBe` cd "/sys/class" sysfsRootZ - cd "/sys/class/gpio/../../class" sysfsRootZ `shouldBe` cd "/sys/../sys/class/../class/gpio/.." sysfsRootZ - cd "/sys/class/gpio/../../.." sysfsRootZ `shouldBe` Right sysfsRootZ - it "'..' beyond root clamps to root" $ - do cd "/sys/class/../../../.." sysfsRootZ `shouldBe` Right sysfsRootZ - cd "/../.." sysfsRootZ `shouldBe` Right sysfsRootZ - - context "absolute and relative paths" $ do - it "produce the same result when they lead to the same directory" $ - do cd "sys/class/gpio" sysfsRootZ `shouldBe` cd "/sys/class/gpio" sysfsRootZ - cd "sys/class/gpio/.." sysfsRootZ `shouldBe` cd "/sys/class/gpio/.." sysfsRootZ - cd "sys/class/gpio/../../." sysfsRootZ `shouldBe` cd "/sys/class/gpio/../../." sysfsRootZ - cd "sys/class/.././class/../../sys" sysfsRootZ `shouldBe` cd "/sys/../sys/class/./gpio/../.." sysfsRootZ - - describe "mkdir" $ - do it "creates a subdirectory in the current directory" $ - do let Right z1@(MockFSZipper dir1 crumb1) = mkdir "xyzzy" sysfsRootZ - dirName dir1 `shouldBe` "/" - crumb1 `shouldBe` [] - let Right (MockFSZipper dir2 (crumb2:_)) = cd "xyzzy" z1 - dirName dir2 `shouldBe` "xyzzy" - parentName crumb2 `shouldBe` "/" - - it "can create multiple subdirectories in the same directory" $ - do let Right z1@(MockFSZipper dir1 crumb1) = mkdir "xyzzy" sysfsRootZ - dirName dir1 `shouldBe` "/" - crumb1 `shouldBe` [] - let Right z2@(MockFSZipper dir2 crumb2) = mkdir "plugh" z1 - dirName dir2 `shouldBe` "/" - crumb2 `shouldBe` [] - let Right z3@(MockFSZipper dir3 (crumb3:_)) = cd "xyzzy" z2 - dirName dir3 `shouldBe` "xyzzy" - parentName crumb3 `shouldBe` "/" - let Right (MockFSZipper dir4 (crumb4:_)) = cd "../plugh" z3 - dirName dir4 `shouldBe` "plugh" - parentName crumb4 `shouldBe` "/" - - it "works when nested" $ - do let Right (MockFSZipper dir (crumb:_)) = mkdir "abc" sysfsRootZ >>= cd "/abc" >>= mkdir "def" >>= cd "/abc/def" - dirName dir `shouldBe` "def" - parentName crumb `shouldBe` "abc" - - it "fails when a subdir with the same name already exists" $ - do let Left result = mkdir "sys" sysfsRootZ - isAlreadyExistsError result `shouldBe` True - - it "fails when a file with the same name already exists" $ - do let Left result = (cd "/sys/class/gpio" sysfsRootZ >>= mkdir "export") - isAlreadyExistsError result `shouldBe` True - - it "fails with an invalid name" $ - do let Left result = mkdir "" sysfsRootZ - isInvalidArgumentError result `shouldBe` True - - it "fails when the name contains a '/'" $ - do let Left result1 = mkdir "/abc" sysfsRootZ - isInvalidArgumentError result1 `shouldBe` True - let Left result2 = mkdir "sys/foobar" sysfsRootZ - isInvalidArgumentError result2 `shouldBe` True - - describe "mkfile" $ - do it "creates a file in the current directory when clobber is False" $ - do let Right z1 = cd "/sys/class/gpio" sysfsRootZ - let Right (MockFSZipper dir2 (crumb2:_)) = mkfile "gpio1" (Const ["Hey!", "This is gpio1"]) False z1 - dirName dir2 `shouldBe` "gpio" - parentName crumb2 `shouldBe` "class" - let file:rest = files dir2 - _fileName file `shouldBe` "gpio1" - _fileType file `shouldBe` (Const ["Hey!", "This is gpio1"]) - rest `shouldBe` [File {_fileName = "export", _fileType = Export},File {_fileName = "unexport", _fileType = Unexport}] - - it "creates a file in the current directory when clobber is True" $ - do let Right z1 = cd "/sys/class/gpio" sysfsRootZ - let Right (MockFSZipper dir2 (crumb2:_)) = mkfile "gpio1" (Const ["Hey!", "This is gpio1"]) True z1 - dirName dir2 `shouldBe` "gpio" - parentName crumb2 `shouldBe` "class" - let file:rest = files dir2 - _fileName file `shouldBe` "gpio1" - _fileType file `shouldBe` (Const ["Hey!", "This is gpio1"]) - rest `shouldBe` [File {_fileName = "export", _fileType = Export},File {_fileName = "unexport", _fileType = Unexport}] - - it "fails when a subdir with the same name already exists" $ do - let Left result1 = mkfile "sys" (Const []) True sysfsRootZ - isAlreadyExistsError result1 `shouldBe` True - let Left result2 = mkfile "sys" (Const []) False sysfsRootZ - isAlreadyExistsError result2 `shouldBe` True - - it "fails when a file with the same name already exists and clobber is False" $ - do let Left result = (cd "/sys/class/gpio" sysfsRootZ >>= mkfile "export" (Const []) False) - isAlreadyExistsError result `shouldBe` True - - it "overwrites an existing file's contents when a file with the same name already exists and clobber is True" $ - do let Right z1 = cd "/sys/class/gpio" sysfsRootZ - let Right z2 = mkfile "gpio1" (Const ["Hey!", "This is gpio1"]) False z1 - let Right (MockFSZipper dir3 (crumb3:_)) = mkfile "gpio1" (Const ["Hey!", "Now I'm gpio1"]) True z2 - dirName dir3 `shouldBe` "gpio" - parentName crumb3 `shouldBe` "class" - let file:rest = files dir3 - _fileName file `shouldBe` "gpio1" - _fileType file `shouldBe` (Const ["Hey!", "Now I'm gpio1"]) - rest `shouldBe` [File {_fileName = "export", _fileType = Export},File {_fileName = "unexport", _fileType = Unexport}] - - it "fails with an invalid name" $ do - let Left result1 = mkfile "" (Const []) False sysfsRootZ - isInvalidArgumentError result1 `shouldBe` True - let Left result2 = mkfile "" (Const []) True sysfsRootZ - isInvalidArgumentError result2 `shouldBe` True - - it "fails when the name contains a '/'" $ - do let Left result1 = mkfile "/abc" (Const []) False sysfsRootZ - isInvalidArgumentError result1 `shouldBe` True - let Left result2 = mkfile "/abc" (Const []) True sysfsRootZ - isInvalidArgumentError result2 `shouldBe` True - let Left result3 = mkfile "sys/foobar" (Const []) False sysfsRootZ - isInvalidArgumentError result3 `shouldBe` True - let Left result4 = mkfile "sys/foobar" (Const []) True sysfsRootZ - isInvalidArgumentError result4 `shouldBe` True - - describe "findFile" $ - do it "finds files in the current directory" $ - do let Right z1@(MockFSZipper dir1 _) = cd "/sys/class/gpio" sysfsRootZ - findFile "export" dir1 `shouldBe` (Just Export) - findFile "unexport" dir1 `shouldBe` (Just Unexport) - let Right (MockFSZipper dir2 _) = mkfile "gpio1" (Const ["Hey!", "This is gpio1"]) False z1 - findFile "gpio1" dir2 `shouldBe` (Just ((Const ["Hey!", "This is gpio1"]))) - it "doesn't find subdirectories in the current directory" $ - do let Right (MockFSZipper dir1 _) = cd "/sys/class" sysfsRootZ - findFile "gpio" dir1 `shouldBe` Nothing - it "returns failure on non-existent files" $ - do let Right (MockFSZipper dir1 _) = cd "/sys/class" sysfsRootZ - findFile "foobar" dir1 `shouldBe` Nothing - findFile "export" dir1 `shouldBe` Nothing - it "doesn't find files in subdirectories of the current directory" $ - do let Right (MockFSZipper dir1 _) = cd "/sys/class" sysfsRootZ - findFile "gpio/export" dir1 `shouldBe` Nothing - - describe "rmdir" $ - do it "removes a subdirectory of the current directory" $ - do let Right z1 = cd "/sys" sysfsRootZ >>= mkdir "xyzzy" >>= mkdir "plugh" - let Right z2@(MockFSZipper dir2 (crumb2:_)) = rmdir "xyzzy" z1 - dirName dir2 `shouldBe` "sys" - parentName crumb2 `shouldBe` "/" - let Right (MockFSZipper dir3 (crumb3:_)) = rmdir "plugh" z2 - dirName dir3 `shouldBe` "sys" - parentName crumb3 `shouldBe` "/" - - it "fails when no subdir with the name exists" $ - do let Left result = rmdir "foo" sysfsRootZ - isDoesNotExistError result `shouldBe` True - - it "fails when a file is named" $ - do let Left result = (cd "/sys/class/gpio" sysfsRootZ >>= rmdir "export") - isInappropriateTypeError result `shouldBe` True - - it "fails when the name contains a '/'" $ - do let Left result1 = rmdir "/sys" sysfsRootZ - isDoesNotExistError result1 `shouldBe` True - let Left result2 = rmdir "sys/class" sysfsRootZ - isDoesNotExistError result2 `shouldBe` True - - describe "rmfile" $ - do it "removes a file in the current directory" $ - do let Right z1 = cd "/sys" sysfsRootZ >>= mkfile "abc" (Const []) False >>= mkfile "def" (Const []) False - let Right z2@(MockFSZipper dir2 (crumb2:_)) = rmfile "abc" z1 - dirName dir2 `shouldBe` "sys" - parentName crumb2 `shouldBe` "/" - files dir2 `shouldBe` [File {_fileName = "def", _fileType = (Const [])}] - let Right (MockFSZipper dir3 (crumb3:_)) = rmfile "def" z2 - dirName dir3 `shouldBe` "sys" - parentName crumb3 `shouldBe` "/" - files dir3 `shouldBe` [] - - it "fails when no file with the name exists" $ - do let Left result = rmfile "foo" sysfsRootZ - isDoesNotExistError result `shouldBe` True - - it "fails when a directory is named" $ - do let Left result = (cd "/sys/class" sysfsRootZ >>= rmfile "gpio") - isInappropriateTypeError result `shouldBe` True - - it "fails when the name contains a '/'" $ - do let Left result = rmfile "/sys/class/gpio/export" sysfsRootZ - isDoesNotExistError result `shouldBe` True - - describe "pathFromRoot" $ - do it "returns the path from the current directory to the root directory" $ - do pathFromRoot sysfsRootZ `shouldBe` "/" - let Right z1 = cd "/sys/class/gpio" sysfsRootZ - pathFromRoot z1 `shouldBe` "/sys/class/gpio" - let Right z2 = cd "/sys/class/gpio/../../class" sysfsRootZ - pathFromRoot z2 `shouldBe` "/sys/class" diff --git a/test/System/GPIO/Linux/Sysfs/MockSpec.hs b/test/System/GPIO/Linux/Sysfs/MockSpec.hs deleted file mode 100644 --- a/test/System/GPIO/Linux/Sysfs/MockSpec.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-incomplete-uni-patterns #-} -{-# LANGUAGE OverloadedStrings #-} - -module System.GPIO.Linux.Sysfs.MockSpec (spec) where - -import Prelude hiding (readFile, writeFile) -import Control.Exception (fromException) -import Data.List (sort) -import GHC.IO.Exception (IOErrorType(..)) -import System.GPIO.Linux.Sysfs.Mock -import System.GPIO.Types (Pin(..), PinValue(..)) -import System.IO.Error (ioeGetErrorType, isDoesNotExistError, isPermissionError) -import Test.Hspec - -isInappropriateTypeErrorType :: IOErrorType -> Bool -isInappropriateTypeErrorType InappropriateType = True -isInappropriateTypeErrorType _ = False - -isInappropriateTypeError :: IOError -> Bool -isInappropriateTypeError = isInappropriateTypeErrorType . ioeGetErrorType - -evalSysfsMock' :: SysfsMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe IOError) a -evalSysfsMock' a w c = either (Left . fromException) Right $ evalSysfsMock a w c - -evalSysfsMockME :: SysfsMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe MockFSException) a -evalSysfsMockME a w c = either (Left . fromException) Right $ evalSysfsMock a w c - -execSysfsMock' :: SysfsMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe IOError) MockWorld -execSysfsMock' a w c = either (Left . fromException) Right $ execSysfsMock a w c - -spec :: Spec -spec = - do - describe "MockPinState" $ do - it "logicalValue returns the correct pin value" $ - let pinState = defaultMockPinState {_value = Low, _activeLow = False} - in do - logicalValue pinState `shouldBe` Low - logicalValue (pinState {_value = High}) `shouldBe` High - logicalValue (pinState {_activeLow = True}) `shouldBe` High - logicalValue (pinState {_value = High, _activeLow = True}) `shouldBe` Low - it "setLogicalValue sets the correct pin value" $ - let pinState = defaultMockPinState {_value = Low, _activeLow = False} - activeLowPinState = defaultMockPinState {_value = Low, _activeLow = True} - in do - setLogicalValue Low pinState `shouldBe` pinState - setLogicalValue High pinState `shouldBe` pinState {_value = High} - setLogicalValue Low activeLowPinState `shouldBe` activeLowPinState {_value = High} - setLogicalValue High activeLowPinState `shouldBe` activeLowPinState {_value = Low} - - describe "SysfsMockT" $ do - - context "doesDirectoryExist" $ do - it "relative paths are relative to the initial zipper's working directory" $ do - evalSysfsMock' (doesDirectoryExist "sys/class/gpio") initialMockWorld [] `shouldBe` Right True - it "absolute paths work regardless of the initial zipper's working directory" $ do - evalSysfsMock' (doesDirectoryExist "/sys/class/gpio") initialMockWorld [] `shouldBe` Right True - it "doesn't change the initial zipper's state" $ do - execSysfsMock' (doesDirectoryExist "/sys/class/gpio") initialMockWorld [] `shouldBe` Right initialMockWorld - it "returns False on files" $ do - evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/export") initialMockWorld [] `shouldBe` Right False - it "returns False on non-existent names" $ do - evalSysfsMock' (doesDirectoryExist "/sys/class/foobar") initialMockWorld [] `shouldBe` Right False - - context "doesFileExist" $ do - it "relative paths are relative to the initial zipper's working directory" $ do - evalSysfsMock' (doesFileExist "sys/class/gpio/export") initialMockWorld [] `shouldBe` Right True - it "absolute paths work regardless of the initial zipper's working directory" $ do - evalSysfsMock' (doesFileExist "/sys/class/gpio/export") initialMockWorld [] `shouldBe` Right True - it "doesn't change the initial zipper's state" $ do - execSysfsMock' (doesFileExist "/sys/class/gpio/export") initialMockWorld [] `shouldBe` Right initialMockWorld - it "returns False on directories" $ do - evalSysfsMock' (doesFileExist "/sys/class/gpio") initialMockWorld [] `shouldBe` Right False - it "returns False on non-existent names" $ do - evalSysfsMock' (doesFileExist "/sys/class/foobar") initialMockWorld [] `shouldBe` Right False - - context "getDirectoryContents" $ do - it "relative paths are relative to the initial zipper's working directory" $ do - fmap sort (evalSysfsMock' (getDirectoryContents "sys/class") initialMockWorld []) `shouldBe` Right ["gpio"] - fmap sort (evalSysfsMock' (getDirectoryContents "sys/class/gpio") initialMockWorld []) `shouldBe` (Right $ sort ["export", "unexport"]) - it "absolute paths work regardless of the initial zipper's working directory" $ do - fmap sort (evalSysfsMock' (getDirectoryContents "/sys/class") initialMockWorld []) `shouldBe` Right ["gpio"] - fmap sort (evalSysfsMock' (getDirectoryContents "/sys/class/gpio") initialMockWorld []) `shouldBe` (Right $ sort ["export", "unexport"]) - it "doesn't change the initial zipper's state" $ do - execSysfsMock' (getDirectoryContents "/sys/class/gpio") initialMockWorld [] `shouldBe` Right initialMockWorld - it "returns failure on files" $ do - do let Left (Just result) = evalSysfsMock' (getDirectoryContents "/sys/class/gpio/export") initialMockWorld [] - isInappropriateTypeError result `shouldBe` True - it "returns failure on non-existent names" $ do - do let Left (Just result) = evalSysfsMock' (getDirectoryContents "/sys/class/foobar") initialMockWorld [] - isDoesNotExistError result `shouldBe` True - - context "readFile" $ do - -- Note: most interesting cases are already checked by the - -- tests in 'SysfsGpioMockSpec.hs' and it would be a bit silly - -- to try to test them here due to the amount of setup - -- required to get the filesystem into the necessary state. - -- (We would basically end up rewriting large chunks of the - -- mock GPIO code.) - it "works with 'constant' files" $ - let chip0 = MockGpioChip "chip0" 0 (replicate 16 defaultMockPinState) - in evalSysfsMock' (readFile "/sys/class/gpio/gpiochip0/base") initialMockWorld [chip0] `shouldBe` Right "0\n" - it "fails on /sys/class/gpio/export" $ - do let Left (Just result) = evalSysfsMock' (readFile "/sys/class/gpio/export") initialMockWorld [] - isPermissionError result `shouldBe` True - it "fails on /sys/class/gpio/unexport" $ - do let Left (Just result) = evalSysfsMock' (readFile "/sys/class/gpio/unexport") initialMockWorld [] - isPermissionError result `shouldBe` True - it "fails on non-existent file" $ - do let Left (Just result) = evalSysfsMock' (readFile "/sys/class/gpio/foo") initialMockWorld [] - isDoesNotExistError result `shouldBe` True - it "fails on a directory" $ - do let Left (Just result) = evalSysfsMock' (readFile "/sys/class/gpio") initialMockWorld [] - isInappropriateTypeError result `shouldBe` True - - context "writeFile" $ - it "does the right thing" $ - pendingWith "Not implemented" -- See notes for 'readFile' - -- above. - - context "runSysfsMockT" $ do - let chip0 = MockGpioChip "chip0" 0 (replicate 16 defaultMockPinState) - chip16 = MockGpioChip "xyz" 16 (replicate 32 defaultMockPinState) - chip64 = MockGpioChip "abc" 64 (replicate 16 defaultMockPinState) - invalidChip32 = MockGpioChip "invalid" 32 (replicate 16 defaultMockPinState) - it "creates the specified gpiochip directories" $ do - fmap sort (evalSysfsMock' (getDirectoryContents "/sys/class/gpio") initialMockWorld [chip0, chip16, chip64]) `shouldBe` Right ["export", "gpiochip0", "gpiochip16", "gpiochip64", "unexport"] - evalSysfsMock' (readFile "/sys/class/gpio/gpiochip0/base") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "0\n" - evalSysfsMock' (readFile "/sys/class/gpio/gpiochip0/ngpio") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "16\n" - evalSysfsMock' (readFile "/sys/class/gpio/gpiochip0/label") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "chip0\n" - evalSysfsMock' (readFile "/sys/class/gpio/gpiochip16/base") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "16\n" - evalSysfsMock' (readFile "/sys/class/gpio/gpiochip16/ngpio") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "32\n" - evalSysfsMock' (readFile "/sys/class/gpio/gpiochip16/label") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "xyz\n" - evalSysfsMock' (readFile "/sys/class/gpio/gpiochip64/base") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "64\n" - evalSysfsMock' (readFile "/sys/class/gpio/gpiochip64/ngpio") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "16\n" - evalSysfsMock' (readFile "/sys/class/gpio/gpiochip64/label") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "abc\n" - it "fails when MockGpioChips overlap" $ do - evalSysfsMockME (readFile "/sys/class/gpio/gpiochip16/ngpio") initialMockWorld [chip0, chip16, invalidChip32] `shouldBe` Left (Just $ GpioChipOverlap $ Pin 47) diff --git a/test/System/GPIO/Linux/Sysfs/SysfsGpioMockSpec.hs b/test/System/GPIO/Linux/Sysfs/SysfsGpioMockSpec.hs deleted file mode 100644 --- a/test/System/GPIO/Linux/Sysfs/SysfsGpioMockSpec.hs +++ /dev/null @@ -1,879 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-incomplete-uni-patterns #-} -{-# LANGUAGE OverloadedStrings #-} - -module System.GPIO.Linux.Sysfs.SysfsGpioMockSpec (spec) where - -import Control.Exception (fromException) -import Control.Monad (void) -import Control.Monad.Catch (MonadCatch, MonadMask, handle) -import qualified Data.Map.Strict as Map (lookup) -import qualified Data.Set as Set (empty, fromList) - -import System.GPIO.Linux.Sysfs.Mock -import System.GPIO.Linux.Sysfs.Types (SysfsEdge(..), SysfsException(..)) -import System.GPIO.Monad - -import Test.Hspec - --- To some extent, these tests only test the implementation of the --- Mock interpreter, which isn't particularly valuable on its own. --- However, it does allow us to test that we're able to express the --- kinds of GpioT programs we want, in a pure environment (and when --- the platform we're developing on doesn't actually have GPIO --- functionality). - -testOpenClose :: (MonadGpio h m) => m () -testOpenClose = - do h <- openPin (Pin 1) - closePin h - -testSetInterruptMode :: (MonadGpio h m) => m (PinInterruptMode, PinInterruptMode, PinInterruptMode, PinInterruptMode) -testSetInterruptMode = - do d <- openPin (Pin 1) - setPinInputMode d InputDefault - setPinInterruptMode d Disabled - t1 <- getPinInterruptMode d - setPinInterruptMode d RisingEdge - t2 <- getPinInterruptMode d - setPinInterruptMode d FallingEdge - t3 <- getPinInterruptMode d - setPinInterruptMode d Level - t4 <- getPinInterruptMode d - closePin d - return (t1, t2, t3, t4) - -testSetInterruptModeIdempotent :: (MonadGpio h m) => m (PinInterruptMode, PinInterruptMode) -testSetInterruptModeIdempotent = - do d <- openPin (Pin 1) - setPinInputMode d InputDefault - setPinInterruptMode d FallingEdge - t1 <- getPinInterruptMode d - setPinInterruptMode d FallingEdge - t2 <- getPinInterruptMode d - closePin d - return (t1, t2) - -testReadWritePin :: (MonadGpio h m) => h -> m (PinValue, PinValue, PinValue) -testReadWritePin d = - do val1 <- readPin d - case val1 of - Low -> - do writePin d High - val2 <- readPin d - writePin d Low - val3 <- readPin d - return (val1,val2,val3) - High -> - do writePin d Low - val2 <- readPin d - writePin d High - val3 <- readPin d - return (val1,val2,val3) - -testReadWritePinIdempotent :: (MonadGpio h m) => m (PinValue, PinValue) -testReadWritePinIdempotent = - do d <- openPin (Pin 1) - setPinOutputMode d OutputDefault Low - val1 <- readPin d - case val1 of - Low -> - do writePin d Low - val2 <- readPin d - closePin d - return (val1,val2) - High -> - do writePin d High - val2 <- readPin d - closePin d - return (val1,val2) - -testWritePinFailsOnInputPin :: (MonadGpio h m) => m () -testWritePinFailsOnInputPin = - do d <- openPin (Pin 1) - setPinInputMode d InputDefault - writePin d High - closePin d - -testTogglePinValue :: (MonadGpio h m) => m (PinValue, PinValue, PinValue, PinValue, PinValue) -testTogglePinValue = - do d <- openPin (Pin 1) - setPinOutputMode d OutputDefault Low - val1 <- readPin d - val2 <- togglePin d - val3 <- readPin d - val4 <- togglePin d - val5 <- readPin d - closePin d - return (val1, val2, val3, val4, val5) - -testTogglePinActiveLevel :: (MonadGpio h m) => h -> m (PinActiveLevel, PinActiveLevel, PinActiveLevel, PinActiveLevel, PinActiveLevel) -testTogglePinActiveLevel h = - do val1 <- getPinActiveLevel h - val2 <- togglePinActiveLevel h - val3 <- getPinActiveLevel h - val4 <- togglePinActiveLevel h - val5 <- getPinActiveLevel h - return (val1, val2, val3, val4, val5) - -invalidHandle :: (MonadGpio h m) => (h -> m a) -> m a -invalidHandle action = - do d <- openPin (Pin 1) - closePin d - action d - -testWithPin :: (MonadGpio h m, MonadMask m) => m PinValue -testWithPin = withPin (Pin 1) $ \h -> - do setPinOutputMode h OutputDefault Low - writePin h High - val <- readPin h - return val - -testNestedWithPin :: (MonadGpio h m, MonadMask m) => Pin -> Pin -> m (PinValue, PinValue) -testNestedWithPin p1 p2 = - withPin p1 $ \h1 -> - withPin p2 $ \h2 -> - do setPinOutputMode h1 OutputDefault Low - setPinOutputMode h2 OutputDefault Low - writePin h1 High - writePin h2 Low - val1 <- readPin h1 - val2 <- readPin h2 - return (val1, val2) - -handleGpioException :: MonadCatch m => (SomeGpioException -> m a) -> m a -> m a -handleGpioException = handle - -testWithPinError :: (MonadGpio h m, MonadMask m, MonadCatch m) => Pin -> Pin -> m (Maybe PinValue) -testWithPinError p1 p2 = handleGpioException (const $ return Nothing) $ - withPin p1 $ \h1 -> - withPin p2 $ \h2 -> - do setPinOutputMode h1 OutputDefault Low - setPinInputMode h2 InputDefault - writePin h1 High -- should fail if p1 == p2 - writePin h2 Low -- should fail in any case - val1 <- readPin h1 - return $ Just val1 - -chip0 :: MockGpioChip -chip0 = MockGpioChip "chip0" 0 (replicate 16 defaultMockPinState) - -chip1 :: MockGpioChip -chip1 = MockGpioChip "chip1" 32 (replicate 32 defaultMockPinState) - -evalSysfsGpioMock' :: SysfsGpioMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe SysfsException) a -evalSysfsGpioMock' a w c = either (Left . fromException) return $ evalSysfsGpioMock a w c - -execSysfsGpioMock' :: SysfsGpioMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe SysfsException) MockWorld -execSysfsGpioMock' a w c = either (Left . fromException) return $ execSysfsGpioMock a w c - -runSysfsGpioMock' :: SysfsGpioMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe SysfsException) (a, MockWorld) -runSysfsGpioMock' a w c = either (Left . fromException) return $ runSysfsGpioMock a w c - -evalSysfsMock' :: SysfsMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe SysfsException) a -evalSysfsMock' a w c = either (Left . fromException) Right $ evalSysfsMock a w c - -spec :: Spec -spec = - do describe "pins" $ - let pinList = map Pin [0..15] - expectedResult = Right pinList - in - it "returns the list of available pins" $ - evalSysfsGpioMock' pins initialMockWorld [chip0] `shouldBe` expectedResult - - describe "pinCapabilities" $ - do it "returns a pin's capabilities" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState - ,defaultMockPinState {_userVisibleDirection = False} - ,defaultMockPinState {_edge = Nothing}] - (Right result) = - evalSysfsGpioMock' - (do c1 <- pinCapabilities (Pin 1) - c2 <- pinCapabilities (Pin 2) - c3 <- pinCapabilities (Pin 3) - return (c1,c2,c3) - ) - initialMockWorld - [testChip] - in do result - `shouldBe` - (PinCapabilities (Set.fromList [InputDefault]) (Set.fromList [OutputDefault]) True, - PinCapabilities Set.empty Set.empty False, - PinCapabilities (Set.fromList [InputDefault]) (Set.fromList [OutputDefault]) False) - it "doesn't leave any pin state around" $ - let (Right world) = - execSysfsGpioMock (void $ pinCapabilities (Pin 1)) initialMockWorld [chip0] - in evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False - it "fails if the pin doesn't exist" $ - let (Left failure) = - evalSysfsGpioMock' (pinCapabilities (Pin 99)) initialMockWorld [chip0] - in failure `shouldBe` (Just $ InvalidPin (Pin 99)) - - describe "openPin/closePin" $ - do it "cleans up properly" $ - let (Right world) = execSysfsGpioMock' testOpenClose initialMockWorld [chip0] - in evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False - it "fails when the pin is unavailable" $ - evalSysfsGpioMock' testOpenClose initialMockWorld [chip1] `shouldBe` Left (Just $ InvalidPin (Pin 1)) - it "openPin does not error when the pin is already open" $ - evalSysfsGpioMock' (openPin (Pin 1) >> openPin (Pin 1) >> return ()) initialMockWorld [chip0] `shouldBe` Right () - - it "closePin does not error when the pin is already closed" $ - evalSysfsGpioMock' (do { h <- openPin (Pin 1) ; closePin h ; closePin h} ) initialMockWorld [chip0] `shouldBe` Right () - - describe "getPinDirection" $ - do it "gets the pin's direction" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In}] - in - do evalSysfsGpioMock' (withPin (Pin 1) getPinDirection) initialMockWorld [chip0] `shouldBe` Right Out - evalSysfsGpioMock' (withPin (Pin 1) getPinDirection) initialMockWorld [testChip] `shouldBe` Right In - - it "fails when the pin direction is not settable" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_userVisibleDirection = False}] - in evalSysfsGpioMock' (withPin (Pin 1) getPinDirection) initialMockWorld [testChip] `shouldBe` Left (Just $ NoDirectionAttribute (Pin 1)) - - describe "getPinInputMode" $ - do it "gets the pin's input mode" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In}] - in - evalSysfsGpioMock' (withPin (Pin 1) getPinInputMode) initialMockWorld [testChip] `shouldBe` Right InputDefault - it "fails when the pin's direction is Out" $ - evalSysfsGpioMock' (withPin (Pin 1) getPinInputMode) initialMockWorld [chip0] `shouldBe` Left (Just $ InvalidOperation (Pin 1)) - - describe "setPinInputMode" $ - do it "sets the pin's input mode and direction" $ - let testChip1 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = Out, _edge = Just Falling, _activeLow = True}] - testChip2 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _edge = Just Rising}] - (Right (result1,world1)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinInputMode h InputDefault >> getPinInputMode h) initialMockWorld [testChip1] - (Right (result2,world2)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinInputMode h InputDefault >> getPinInputMode h) initialMockWorld [testChip2] - in do result1 `shouldBe` InputDefault - result2 `shouldBe` InputDefault - Map.lookup (Pin 1) (mockWorldPins world1) `shouldBe` Just (defaultMockPinState {_direction = In, _edge = Just Falling, _activeLow = True}) - Map.lookup (Pin 1) (mockWorldPins world2) `shouldBe` Just (defaultMockPinState {_direction = In, _edge = Just Rising}) - - it "fails when the input mode is unsupported" $ - evalSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinInputMode h InputFloating) initialMockWorld [chip0] `shouldBe` Left (Just $ (UnsupportedInputMode InputFloating (Pin 1))) - it "fails when the pin's direction is not settable" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_userVisibleDirection = False}] - in evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinInputMode h InputDefault)) initialMockWorld [testChip] `shouldBe` Left (Just $ NoDirectionAttribute (Pin 1)) - - describe "getPinOutputMode" $ - do it "gets the pin's output mode" $ - evalSysfsGpioMock' (withPin (Pin 1) getPinOutputMode) initialMockWorld [chip0] `shouldBe` Right OutputDefault - it "fails when the pin's direction is Out" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In}] - in evalSysfsGpioMock' (withPin (Pin 1) getPinOutputMode) initialMockWorld [testChip] `shouldBe` Left (Just $ InvalidOperation (Pin 1)) - - describe "setPinOutputMode" $ - do it "sets the pin's output mode, value, and direction" $ - let testChip1 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _value = Low}] - (Right (result1,world1)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault High >> getPinOutputMode h) initialMockWorld [testChip1] - testChip2 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _value = Low}] - (Right (result2,world2)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault Low >> getPinOutputMode h) initialMockWorld [testChip2] - testChip3 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = Out, _value = High}] - (Right (result3,world3)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault Low >> getPinOutputMode h) initialMockWorld [testChip3] - (Right (result4,world4)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault High >> getPinOutputMode h) initialMockWorld [chip0] - in do result1 `shouldBe` OutputDefault - result2 `shouldBe` OutputDefault - result3 `shouldBe` OutputDefault - result4 `shouldBe` OutputDefault - Map.lookup (Pin 1) (mockWorldPins world1) `shouldBe` Just (defaultMockPinState {_direction = Out, _value = High}) - Map.lookup (Pin 1) (mockWorldPins world2) `shouldBe` Just (defaultMockPinState {_direction = Out, _value = Low}) - Map.lookup (Pin 1) (mockWorldPins world3) `shouldBe` Just (defaultMockPinState {_direction = Out, _value = Low}) - Map.lookup (Pin 1) (mockWorldPins world4) `shouldBe` Just (defaultMockPinState {_direction = Out, _value = High}) - it "respects the pin's active level" $ - let testChip1 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _value = Low, _activeLow = True}] - (Right (result1,world1)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault High >> getPinOutputMode h) initialMockWorld [testChip1] - testChip2 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _value = Low, _activeLow = True}] - (Right (result2,world2)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault Low >> getPinOutputMode h) initialMockWorld [testChip2] - testChip3 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = Out, _value = High, _activeLow = True}] - (Right (result3,world3)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault Low >> getPinOutputMode h) initialMockWorld [testChip3] - testChip4 = MockGpioChip "testChip" 1 [defaultMockPinState {_activeLow = True}] - (Right (result4,world4)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault High >> getPinOutputMode h) initialMockWorld [testChip4] - in do result1 `shouldBe` OutputDefault - result2 `shouldBe` OutputDefault - result3 `shouldBe` OutputDefault - result4 `shouldBe` OutputDefault - Map.lookup (Pin 1) (mockWorldPins world1) `shouldBe` Just (defaultMockPinState {_direction = Out, _activeLow = True, _value = Low}) - Map.lookup (Pin 1) (mockWorldPins world2) `shouldBe` Just (defaultMockPinState {_direction = Out, _activeLow = True, _value = High}) - Map.lookup (Pin 1) (mockWorldPins world3) `shouldBe` Just (defaultMockPinState {_direction = Out, _activeLow = True, _value = High}) - Map.lookup (Pin 1) (mockWorldPins world4) `shouldBe` Just (defaultMockPinState {_direction = Out, _activeLow = True, _value = Low}) - it "fails when the output mode is unsupported" $ - evalSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputPushPull Low) initialMockWorld [chip0] `shouldBe` Left (Just $ (UnsupportedOutputMode OutputPushPull (Pin 1))) - it "can change the pin direction to 'Out' when the pin is configured for edge- or level-triggered reads " $ - evalSysfsGpioMock' - (withPin (Pin 1) $ \h -> - do setPinInputMode h InputDefault - setPinInterruptMode h RisingEdge - setPinOutputMode h OutputDefault Low - setPinInputMode h InputDefault - setPinInterruptMode h FallingEdge - setPinOutputMode h OutputDefault Low - setPinInputMode h InputDefault - setPinInterruptMode h Level - setPinOutputMode h OutputDefault Low - return True) - initialMockWorld - [chip0] - `shouldBe` Right True - it "fails when the pin's direction is not settable" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_userVisibleDirection = False}] - in evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinOutputMode h OutputDefault Low)) initialMockWorld [testChip] `shouldBe` Left (Just $ NoDirectionAttribute (Pin 1)) - - describe "getPinInterruptMode" $ - do it "gets the pin's interrupt mode" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_edge = Just Falling}] - in - do evalSysfsGpioMock' (withPin (Pin 1) getPinInterruptMode) initialMockWorld [chip0] `shouldBe` Right Disabled - evalSysfsGpioMock' (withPin (Pin 1) getPinInterruptMode) initialMockWorld [testChip] `shouldBe` Right FallingEdge - - it "fails when the pin's interrupt mode is not settable" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_edge = Nothing}] - in evalSysfsGpioMock' (withPin (Pin 1) getPinInterruptMode) initialMockWorld [testChip] `shouldBe` Left (Just $ NoEdgeAttribute (Pin 1)) - - describe "setPinInterruptMode" $ - do it "sets the pin's interrupt mode" $ - evalSysfsGpioMock' testSetInterruptMode initialMockWorld [chip0] `shouldBe` Right (Disabled, RisingEdge, FallingEdge, Level) - it "is idempotent" $ - evalSysfsGpioMock' testSetInterruptModeIdempotent initialMockWorld [chip0] `shouldBe` Right (FallingEdge, FallingEdge) - it "fails when the pin's interrupt mode is not settable" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_edge = Nothing}, defaultMockPinState] - in evalSysfsGpioMock' testSetInterruptMode initialMockWorld [testChip] `shouldBe` Left (Just $ NoEdgeAttribute (Pin 1)) - it "fails when the pin is configured for output" $ - evalSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinInterruptMode h Level) initialMockWorld [chip0] `shouldBe` Left (Just $ InvalidOperation (Pin 1)) - - describe "getPinActiveLevel" $ - do context "when active level is high" $ - do it "returns the pin's active level" $ - evalSysfsGpioMock' (withPin (Pin 1) getPinActiveLevel) initialMockWorld [chip0] `shouldBe` Right ActiveHigh - context "when active level is low" $ - do it "returns the pin's active level" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_activeLow = True}] - in evalSysfsGpioMock' (withPin (Pin 1) getPinActiveLevel) initialMockWorld [testChip] `shouldBe` Right ActiveLow - - describe "setPinActiveLevel" $ - do context "when active level is high" $ - do it "sets the pin's active level to low" $ - let (Right (result, world)) = runSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveLow >> getPinActiveLevel h)) initialMockWorld [chip0] - in do result `shouldBe` ActiveLow - Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just (defaultMockPinState {_activeLow = True}) - it "sets the pin's active level to high" $ - let (Right (result, world)) = runSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveHigh >> getPinActiveLevel h)) initialMockWorld [chip0] - in do result `shouldBe` ActiveHigh - Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just (defaultMockPinState {_activeLow = False}) - context "when active level is low" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_activeLow = True}] - in do it "sets the pin's active level to low" $ - let (Right (result, world)) = runSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveLow >> getPinActiveLevel h)) initialMockWorld [testChip] - in do result `shouldBe` ActiveLow - Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just (defaultMockPinState {_activeLow = True}) - it "sets the pin's active level to high" $ - let (Right (result, world)) = runSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveHigh >> getPinActiveLevel h)) initialMockWorld [chip0] - in do result `shouldBe` ActiveHigh - Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just (defaultMockPinState {_activeLow = False}) - - describe "togglePinActiveLevel" $ - do it "toggles the pin's active level when the pin is configured for output" $ - evalSysfsGpioMock' (withPin (Pin 1) testTogglePinActiveLevel) initialMockWorld [chip0] `shouldBe` Right (ActiveHigh, ActiveLow, ActiveLow, ActiveHigh, ActiveHigh) - it "and when the pin is configured for input" $ - evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinInputMode h InputDefault >> testTogglePinActiveLevel h)) initialMockWorld [chip0] `shouldBe` Right (ActiveHigh, ActiveLow, ActiveLow, ActiveHigh, ActiveHigh) - - describe "pollPin" $ - do it "waits for the specified trigger and returns the pin's value" $ - pendingWith "need to implement this" - - it "blocks when the interrupt mode is Disabled, until it is changed" $ - pendingWith "need to implement this" - - describe "pollPinTimeout" $ - do it "waits for the specified trigger and returns the pin's value" $ - pendingWith "need to implement this" - it "blocks when the interrupt mode is Disabled, until it is changed" $ - pendingWith "need to implement this" - it "times out" $ - pendingWith "need to implement this" - - describe "readPin" $ - do context "returns the pin's logical level" $ - do it "when the active level is high" $ - evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveHigh >> readPin h)) initialMockWorld [chip0] `shouldBe` Right Low - it "when the active level is low" $ - evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveLow >> readPin h)) initialMockWorld [chip0] `shouldBe` Right High - - describe "writePin" $ - do context "sets the pin's logical value" $ - do it "when the active level is high" $ - let Right (result, world) = runSysfsGpioMock' (withPin (Pin 1) testReadWritePin) initialMockWorld [chip0] - in do result `shouldBe` (Low, High, Low) - Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState - it "when the active level is low" $ - let Right (result, world) = runSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveLow >> testReadWritePin h)) initialMockWorld [chip0] - in do result `shouldBe` (High, Low, High) - Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just (defaultMockPinState {_activeLow = True, _value = Low}) - - it "is idempotent" $ - evalSysfsGpioMock' testReadWritePinIdempotent initialMockWorld [chip0] `shouldBe` Right (Low, Low) - - it "fails when the pin direction is In" $ - evalSysfsGpioMock' testWritePinFailsOnInputPin initialMockWorld [chip0] `shouldBe` Left (Just $ PermissionDenied (Pin 1)) - - describe "togglePin" $ - do it "toggles the pin's value" $ - evalSysfsGpioMock' testTogglePinValue initialMockWorld [chip0] `shouldBe` Right (Low, High, High, Low, Low) - it "fails when the pin is not configured for output" $ - evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinInputMode h InputDefault >> togglePin h)) initialMockWorld [chip0] `shouldBe` Left (Just $ PermissionDenied (Pin 1)) - - describe "operations on an invalid handle fail" $ - -- Note: When used on an invalid handle, GPIO commands which - -- return a 'Maybe' result will fail differently than commands - -- which do not. This is by design. - do it "in getPinDirection" $ - evalSysfsGpioMock' (invalidHandle getPinDirection) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) - - it "in getPinInputMode" $ - evalSysfsGpioMock' (invalidHandle getPinInputMode) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) - - it "in setPinInputMode" $ - evalSysfsGpioMock' (invalidHandle (\d -> setPinInputMode d InputDefault)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) - - it "in getPinOutputMode" $ - evalSysfsGpioMock' (invalidHandle getPinOutputMode) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) - - it "in setPinOutputMode" $ - evalSysfsGpioMock' (invalidHandle (\h -> setPinOutputMode h OutputDefault Low)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) - - it "in readPin" $ - evalSysfsGpioMock' (invalidHandle readPin) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) - - it "in pollPin" $ - evalSysfsGpioMock' (invalidHandle pollPin) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) - - it "in pollPinTimeout" $ - evalSysfsGpioMock' (invalidHandle (\h -> pollPinTimeout h 10000)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) - - it "in writePin" $ - evalSysfsGpioMock' (invalidHandle (\d -> writePin d High)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) - - it "in togglePin" $ - evalSysfsGpioMock' (invalidHandle togglePin) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) - - it "in getPinInterruptMode" $ - evalSysfsGpioMock' (invalidHandle getPinInterruptMode) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) - - it "in setPinInterruptMode" $ - evalSysfsGpioMock' (invalidHandle (\d -> setPinInterruptMode d Level)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) - - it "in getPinActiveLevel" $ - evalSysfsGpioMock' (invalidHandle getPinActiveLevel) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) - - it "in setPinActiveLevel" $ - evalSysfsGpioMock' (invalidHandle (\d -> setPinActiveLevel d ActiveHigh)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) - - it "in togglePinActiveLevel" $ - evalSysfsGpioMock' (invalidHandle togglePinActiveLevel) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) - - describe "withPin" $ - do it "opens and closes the pin as expected" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_value = High}] - (Right world) = execSysfsGpioMock' testWithPin initialMockWorld [testChip] - in evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False - - it "throws an exception when the pin doesn't exist" $ - evalSysfsGpioMock' testWithPin initialMockWorld [chip1] `shouldBe` Left (Just $ InvalidPin (Pin 1)) - - it "can nest" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_value = High}, defaultMockPinState] - (Right (result, world)) = runSysfsGpioMock' (testNestedWithPin (Pin 1) (Pin 2)) initialMockWorld [testChip] - in do result `shouldBe` (High, Low) - evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False - evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio2") world [] `shouldBe` Right False - - it "handles double-open and double-close without complaint" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_value = High}, defaultMockPinState] - (Right (result, world)) = runSysfsGpioMock' (testNestedWithPin (Pin 1) (Pin 1)) initialMockWorld [testChip] - in do result `shouldBe` (Low, Low) - evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False - - it "cleans up when an exception occurs in the computation" $ - let (Right (result, world)) = runSysfsGpioMock' (testWithPinError (Pin 1) (Pin 2)) initialMockWorld [chip0] - in do result `shouldBe` Nothing - evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False - evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio2") world [] `shouldBe` Right False - - describe "InputPin" $ - do context "withInputPin" $ - do it "opens and configures a pin for input, then closes closes it" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In}, defaultMockPinState {_direction = Out}] - (Right world) = - execSysfsGpioMock' - (withInputPin (Pin 1) InputDefault Nothing $ \_ -> - withInputPin (Pin 2) InputDefault Nothing $ \_ -> - return () - ) - initialMockWorld - [testChip] - in do evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False - evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio2") world [] `shouldBe` Right False - Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In} - Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In} - it "sets the pin's input mode" $ - evalSysfsGpioMock' - (withInputPin (Pin 1) InputDefault Nothing $ \h -> - getInputPinInputMode h - ) - initialMockWorld - [chip0] - `shouldBe` Right InputDefault - it "sets (or doesn't) the pin's active level" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_activeLow = True}, defaultMockPinState {_activeLow = True}] - (Right world) = - execSysfsGpioMock' - (withInputPin (Pin 1) InputDefault Nothing $ \_ -> - withInputPin (Pin 2) InputDefault (Just ActiveHigh) $ \_ -> - return () - ) - initialMockWorld - [testChip] - in do Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} - Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} - it "fails if the pin's direction is fixed" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState, defaultMockPinState {_direction = Out, _userVisibleDirection = False}] - in evalSysfsGpioMock' - (withInputPin (Pin 1) InputDefault Nothing $ \_ -> - withInputPin (Pin 2) InputDefault (Just ActiveHigh) $ \_ -> - return () - ) - initialMockWorld - [testChip] - `shouldBe` - Left (Just $ NoDirectionAttribute (Pin 2)) - context "readInputPin" $ - do it "respects the pin's active level" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_value = High}, defaultMockPinState {_value = Low}] - in evalSysfsGpioMock' - (withInputPin (Pin 1) InputDefault Nothing $ \h1 -> - withInputPin (Pin 2) InputDefault (Just ActiveLow) $ \h2 -> - do v1 <- readInputPin h1 - v2 <- readInputPin h2 - return (v1,v2) - ) - initialMockWorld - [testChip] - `shouldBe` - Right (High,High) - context "getInputPinInputMode" $ - do it "gets the pin's input mode" $ - evalSysfsGpioMock' - (withInputPin (Pin 1) InputDefault Nothing $ \h -> - getInputPinInputMode h - ) - initialMockWorld - [chip0] - `shouldBe` Right InputDefault - context "get/setInputPinActiveLevel" $ - do it "gets/sets the pin's active level" $ - let (Right (result, world)) = - runSysfsGpioMock' - (withInputPin (Pin 1) InputDefault (Just ActiveHigh) $ \h1 -> - withInputPin (Pin 2) InputDefault (Just ActiveLow) $ \h2 -> - do setInputPinActiveLevel h1 ActiveLow - setInputPinActiveLevel h2 ActiveHigh - l1 <- getInputPinActiveLevel h1 - l2 <- getInputPinActiveLevel h2 - return (l1,l2) - ) - initialMockWorld - [chip0] - in do result `shouldBe` (ActiveLow,ActiveHigh) - Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} - Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} - context "toggleInputPinActiveLevel" $ - do it "toggles the pin's active level and returns the new value" $ - let (Right (result, world)) = - runSysfsGpioMock' - (withInputPin (Pin 1) InputDefault (Just ActiveHigh) $ \h1 -> - withInputPin (Pin 2) InputDefault (Just ActiveLow) $ \h2 -> - do l1 <- toggleInputPinActiveLevel h1 - l2 <- toggleInputPinActiveLevel h2 - return (l1,l2) - ) - initialMockWorld - [chip0] - in do result `shouldBe` (ActiveLow,ActiveHigh) - Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} - Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} - describe "InterruptPin" $ - do context "withInterruptPin" $ - do it "opens and configures a pin for interrupts, sets its interrupt mode, then closes closes it" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _edge = Just None}, defaultMockPinState {_direction = Out, _edge = Just Rising}] - (Right world) = - execSysfsGpioMock' - (withInterruptPin (Pin 1) InputDefault FallingEdge Nothing $ \_ -> - withInterruptPin (Pin 2) InputDefault Disabled Nothing $ \_ -> - return () - ) - initialMockWorld - [testChip] - in do evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False - evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio2") world [] `shouldBe` Right False - Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _edge = Just Falling} - Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _edge = Just None} - it "sets (or doesn't) the pin's active level" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_activeLow = True}, defaultMockPinState {_activeLow = True}] - (Right world) = - execSysfsGpioMock' - (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \_ -> - withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveHigh) $ \_ -> - return () - ) - initialMockWorld - [testChip] - in do Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} - Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} - it "fails if the pin's direction is fixed" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState, defaultMockPinState {_direction = Out, _userVisibleDirection = False}] - in evalSysfsGpioMock' - (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \_ -> - withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveHigh) $ \_ -> - return () - ) - initialMockWorld - [testChip] - `shouldBe` - Left (Just $ NoDirectionAttribute (Pin 2)) - it "fails if the pin doesn't support interrupts" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState, defaultMockPinState {_edge = Nothing}] - in evalSysfsGpioMock' - (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \_ -> - withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveHigh) $ \_ -> - return () - ) - initialMockWorld - [testChip] - `shouldBe` - Left (Just $ NoEdgeAttribute (Pin 2)) - context "readInterruptPin" $ - do it "respects the pin's active level" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_value = High}, defaultMockPinState {_value = Low}] - in evalSysfsGpioMock' - (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \h1 -> - withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveLow) $ \h2 -> - do v1 <- readInterruptPin h1 - v2 <- readInterruptPin h2 - return (v1,v2) - ) - initialMockWorld - [testChip] - `shouldBe` - Right (High,High) - context "getInterruptPinInputMode" $ - do it "gets the pin's input mode" $ - evalSysfsGpioMock' - (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \h -> - getInterruptPinInputMode h - ) - initialMockWorld - [chip0] - `shouldBe` Right InputDefault - context "get/setInterruptPinActiveLevel" $ - do it "gets/sets the pin's active level" $ - let (Right (result, world)) = - runSysfsGpioMock' - (withInterruptPin (Pin 1) InputDefault Disabled (Just ActiveHigh) $ \h1 -> - withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveLow) $ \h2 -> - do setInterruptPinActiveLevel h1 ActiveLow - setInterruptPinActiveLevel h2 ActiveHigh - l1 <- getInterruptPinActiveLevel h1 - l2 <- getInterruptPinActiveLevel h2 - return (l1,l2) - ) - initialMockWorld - [chip0] - in do result `shouldBe` (ActiveLow,ActiveHigh) - Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} - Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} - context "toggleInterruptPinActiveLevel" $ - do it "toggles the pin's active level and returns the new value" $ - let (Right (result, world)) = - runSysfsGpioMock' - (withInterruptPin (Pin 1) InputDefault Disabled (Just ActiveHigh) $ \h1 -> - withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveLow) $ \h2 -> - do l1 <- toggleInterruptPinActiveLevel h1 - l2 <- toggleInterruptPinActiveLevel h2 - return (l1,l2) - ) - initialMockWorld - [chip0] - in do result `shouldBe` (ActiveLow,ActiveHigh) - Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} - Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} - context "get/setInterruptPinInterruptMode" $ - do it "gets/sets the pin's interrupt mode" $ - let (Right (result, world)) = - runSysfsGpioMock' - (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \h1 -> - withInterruptPin (Pin 2) InputDefault RisingEdge Nothing $ \h2 -> - do setInterruptPinInterruptMode h1 RisingEdge - setInterruptPinInterruptMode h2 Disabled - m1 <- getInterruptPinInterruptMode h1 - m2 <- getInterruptPinInterruptMode h2 - return (m1,m2) - ) - initialMockWorld - [chip0] - in do result `shouldBe` (RisingEdge,Disabled) - Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _edge = Just Rising} - Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _edge = Just None} - context "pollInterruptPin" $ - do it "waits for interrupts" $ - pendingWith "need to implement this" - it "respects the pin's active level" $ - pendingWith "need to implement this" - - context "pollInterruptPin" $ - do it "waits for interrupts" $ - pendingWith "need to implement this" - it "times out" $ - pendingWith "need to implement this" - it "respects the pin's active level" $ - pendingWith "need to implement this" - describe "OutputPin" $ - do context "withOutputPin" $ - do it "opens and configures a pin for output, sets its value, then closes closes it" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In}, defaultMockPinState {_direction = Out, _value = High}] - (Right world) = - execSysfsGpioMock' - (withOutputPin (Pin 1) OutputDefault Nothing High $ \_ -> - withOutputPin (Pin 2) OutputDefault Nothing Low $ \_ -> - return () - ) - initialMockWorld - [testChip] - in do evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False - evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio2") world [] `shouldBe` Right False - Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = High} - Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = Low} - it "sets (or doesn't) the pin's active level (and the output value is relative to it)" $ - let (Right world) = - execSysfsGpioMock' - (withOutputPin (Pin 1) OutputDefault Nothing Low $ \_ -> - withOutputPin (Pin 2) OutputDefault Nothing High $ \_ -> - withOutputPin (Pin 3) OutputDefault (Just ActiveLow) Low $ \_ -> - withOutputPin (Pin 4) OutputDefault (Just ActiveLow) High $ \_ -> - withOutputPin (Pin 5) OutputDefault (Just ActiveHigh) Low $ \_ -> - withOutputPin (Pin 6) OutputDefault (Just ActiveHigh) High $ \_ -> - return () - ) - initialMockWorld - [chip0] - in do Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState - Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = High} - Map.lookup (Pin 3) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = High} - Map.lookup (Pin 4) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = Low} - Map.lookup (Pin 5) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = Low} - Map.lookup (Pin 6) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = High} - it "fails if the pin's direction is fixed" $ - let testChip = MockGpioChip "testChip" 1 [defaultMockPinState, defaultMockPinState {_direction = Out, _userVisibleDirection = False}] - in evalSysfsGpioMock' - (withOutputPin (Pin 1) OutputDefault Nothing High $ \_ -> - withOutputPin (Pin 2) OutputDefault Nothing Low $ \_ -> - return () - ) - initialMockWorld - [testChip] - `shouldBe` - Left (Just $ NoDirectionAttribute (Pin 2)) - context "readOutputPin" $ - do it "respects the pin's active level" $ - evalSysfsGpioMock' - (withOutputPin (Pin 1) OutputDefault Nothing Low $ \h1 -> - withOutputPin (Pin 2) OutputDefault (Just ActiveLow) High $ \h2 -> - do v1 <- readOutputPin h1 - v2 <- readOutputPin h2 - return (v1,v2) - ) - initialMockWorld - [chip0] - `shouldBe` - Right (Low,High) - context "writeOutputPin" $ - do it "writes the output value and respects the pin's active level" $ - let (Right world) = - execSysfsGpioMock' - (withOutputPin (Pin 1) OutputDefault (Just ActiveLow) High $ \h1 -> - withOutputPin (Pin 2) OutputDefault (Just ActiveLow) Low $ \h2 -> - withOutputPin (Pin 3) OutputDefault (Just ActiveHigh) High $ \h3 -> - withOutputPin (Pin 4) OutputDefault (Just ActiveHigh) Low $ \h4 -> - do writeOutputPin h1 Low - writeOutputPin h2 High - writeOutputPin h3 Low - writeOutputPin h4 High - ) - initialMockWorld - [chip0] - in do Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = High} - Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = Low} - Map.lookup (Pin 3) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = Low} - Map.lookup (Pin 4) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = High} - context "toggleOutputPin" $ - do it "toggles the output value, returns the new value, and respects the pin's active level" $ - let (Right (result, world)) = - runSysfsGpioMock' - (withOutputPin (Pin 1) OutputDefault (Just ActiveLow) High $ \h1 -> - withOutputPin (Pin 2) OutputDefault (Just ActiveLow) Low $ \h2 -> - withOutputPin (Pin 3) OutputDefault (Just ActiveHigh) High $ \h3 -> - withOutputPin (Pin 4) OutputDefault (Just ActiveHigh) Low $ \h4 -> - do v1 <- toggleOutputPin h1 - v2 <- toggleOutputPin h2 - v3 <- toggleOutputPin h3 - v4 <- toggleOutputPin h4 - return (v1,v2,v3,v4) - ) - initialMockWorld - [chip0] - in do result `shouldBe` (Low,High,Low,High) - Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = High} - Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = Low} - Map.lookup (Pin 3) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = Low} - Map.lookup (Pin 4) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = High} - context "getOutputPinOutputMode" $ - do it "gets the pin's input mode" $ - evalSysfsGpioMock' - (withOutputPin (Pin 1) OutputDefault Nothing Low $ \h -> - getOutputPinOutputMode h - ) - initialMockWorld - [chip0] - `shouldBe` Right OutputDefault - context "get/setOutputPinActiveLevel" $ - do it "gets/sets the pin's active level" $ - let (Right (result, world)) = - runSysfsGpioMock' - (withOutputPin (Pin 1) OutputDefault (Just ActiveHigh) Low $ \h1 -> - withOutputPin (Pin 2) OutputDefault (Just ActiveLow) Low $ \h2 -> - do setOutputPinActiveLevel h1 ActiveLow - setOutputPinActiveLevel h2 ActiveHigh - l1 <- getOutputPinActiveLevel h1 - l2 <- getOutputPinActiveLevel h2 - return (l1,l2) - ) - initialMockWorld - [chip0] - in do result `shouldBe` (ActiveLow,ActiveHigh) - Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True} - Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = False, _value = High} - context "toggleOutputPinActiveLevel" $ - do it "toggles the pin's active level and returns the new value" $ - let (Right (result, world)) = - runSysfsGpioMock' - (withOutputPin (Pin 1) OutputDefault (Just ActiveHigh) Low $ \h1 -> - withOutputPin (Pin 2) OutputDefault (Just ActiveLow) Low $ \h2 -> - do l1 <- toggleOutputPinActiveLevel h1 - l2 <- toggleOutputPinActiveLevel h2 - return (l1,l2) - ) - initialMockWorld - [chip0] - in do result `shouldBe` (ActiveLow,ActiveHigh) - Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True} - Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = False, _value = High} diff --git a/test/System/GPIO/TypesSpec.hs b/test/System/GPIO/TypesSpec.hs deleted file mode 100644 --- a/test/System/GPIO/TypesSpec.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -{-# LANGUAGE CPP #-} - -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif - -module System.GPIO.TypesSpec (spec) where - -import System.GPIO.Types - -import Data.Bits -import Test.Hspec -import Test.QuickCheck (property) - --- Test all our hand-derived instances and functions. - --- PinValue mimics Bool with respect to Bits and FiniteBits. --- -ib2v :: (Int -> Bool) -> Int -> PinValue -ib2v f n = boolToValue $ f n - -bi2v :: (Bool -> Int) -> PinValue -> Int -bi2v f a = f (valueToBool a) - -bb2v :: (Bool -> Bool) -> PinValue -> PinValue -bb2v f a = boolToValue $ f (valueToBool a) - -bbb2v :: (Bool -> Bool -> Bool) -> PinValue -> PinValue -> PinValue -bbb2v f a b = boolToValue $ f (valueToBool a) (valueToBool b) - -bib2v :: (Bool -> Int -> Bool) -> PinValue -> Int -> PinValue -bib2v f a n = boolToValue $ f (valueToBool a) n - -#if MIN_VERSION_base(4,8,0) -newBase :: Spec -newBase = - do context "implements the new base-4.8.0.0 FiniteBits typeclass methods" $ - do it "countLeadingZeros" $ property $ - \a -> countLeadingZeros a == bi2v countLeadingZeros a - it "countTrailingZeros" $ property $ - \a -> countTrailingZeros a == bi2v countTrailingZeros a -#else -newBase :: Spec -newBase = return () -#endif - -spec :: Spec -spec = - do describe "Pin" $ - do it "pinNumber" $ property $ - \p@(Pin n) -> n == pinNumber p - - describe "PinDirection" $ - do it "invertDirection" $ - invertDirection In == Out - && invertDirection Out == In - - describe "PinValue" $ - do it "invertValue" $ property $ - \a -> invertValue a == complement a - - it "valueToBool" $ - valueToBool Low == False - && valueToBool High == True - - it "boolToValue" $ - boolToValue False == Low - && boolToValue True == High - - context "implements the Bits typeclass" $ - do it "(.&.)" $ property $ - \a b -> a .&. b == bbb2v (.&.) a b - - it "(.|.)" $ property $ - \a b -> a .|. b == bbb2v (.|.) a b - - it "xor" $ property $ - \a b -> a `xor` b == bbb2v xor a b - - it "complement" $ property $ - \a -> complement a == bb2v complement a - - it "shift" $ property $ - \a n -> a `shift` n == bib2v shift a n - - it "rotate" $ property $ - \a n -> a `rotate` n == bib2v rotate a n - - it "zeroBits" $ property $ - (zeroBits :: PinValue) == boolToValue (zeroBits:: Bool) - - it "bit" $ property $ - \n -> bit n == ib2v bit n - - it "setBit" $ property $ - \a n -> a `setBit` n == bib2v setBit a n - - it "clearBit" $ property $ - \a n -> a `clearBit` n == bib2v clearBit a n - - it "complementBit" $ property $ - \a n -> a `complementBit` n == bib2v complementBit a n - - it "testBit" $ property $ - \a n -> testBit a n == testBit (valueToBool a) n - - it "bitSizeMaybe" $ property $ - \a -> bitSizeMaybe a == bitSizeMaybe (valueToBool a) - - it "bitSize" $ property $ - \a -> bitSize a == bitSize (valueToBool a) - - it "isSigned" $ property $ - \a -> isSigned a == isSigned (valueToBool a) - - it "shiftL" $ property $ - \a n -> a `shiftL` n == bib2v shiftL a n - - it "unsafeShiftL" $ property $ - \a n -> a `unsafeShiftL` n == bib2v unsafeShiftL a n - - it "shiftR" $ property $ - \a n -> a `shiftR` n == bib2v shiftR a n - - it "unsafeShiftR" $ property $ - \a n -> a `unsafeShiftR` n == bib2v unsafeShiftR a n - - it "rotateL" $ property $ - \a n -> a `rotateL` n == bib2v rotateL a n - - it "rotateR" $ property $ - \a n -> a `rotateR` n == bib2v rotateR a n - - it "popCount" $ property $ - \a -> popCount a == popCount (valueToBool a) - - context "implements the FiniteBits typeclass" $ - do it "finiteBitSize" $ property $ - \a -> finiteBitSize a == bi2v finiteBitSize a - - newBase diff --git a/test/Test/System/GPIO/Linux/Sysfs/LinuxBboneSpec.hs b/test/Test/System/GPIO/Linux/Sysfs/LinuxBboneSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/System/GPIO/Linux/Sysfs/LinuxBboneSpec.hs @@ -0,0 +1,1142 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + +module Test.System.GPIO.Linux.Sysfs.LinuxBboneSpec (spec) where + +import Protolude +import Control.Monad.Catch (throwM) +import System.Directory (doesDirectoryExist) +import System.GPIO.Linux.Sysfs (SysfsException(..), runSysfsGpioIO) +import System.GPIO.Monad (MonadGpio(..), withPin) +import System.GPIO.Types + (Pin(..), PinInputMode(..), PinOutputMode(..), PinActiveLevel(..), + PinDirection(..), PinInterruptMode(..), PinValue(..)) +import System.IO.Error (userError) +import Test.Hspec + +isInvalidPinError :: SysfsException -> Bool +isInvalidPinError (InvalidPin _) = True +isInvalidPinError _ = False + +isNotExportedError :: SysfsException -> Bool +isNotExportedError (NotExported _) = True +isNotExportedError _ = False + +isUnsupportedInputMode :: SysfsException -> Bool +isUnsupportedInputMode (UnsupportedInputMode _ _) = True +isUnsupportedInputMode _ = False + +isUnsupportedOutputMode :: SysfsException -> Bool +isUnsupportedOutputMode (UnsupportedOutputMode _ _) = True +isUnsupportedOutputMode _ = False + +isPermissionDeniedError :: SysfsException -> Bool +isPermissionDeniedError (PermissionDenied _) = True +isPermissionDeniedError _ = False + +isInvalidOperationError :: SysfsException -> Bool +isInvalidOperationError (InvalidOperation _) = True +isInvalidOperationError _ = False + +-- Note: it's not practical to test all exceptional cases, but we do +-- our best. + +-- Note: make sure the tests are always compiled, but only actually +-- run on the proper platform. +spec :: Spec +spec = +#ifdef RUN_LINUX_BBONE_TESTS + runTests +#else + describe "Linux BeagleBone tests disabled on this platform" $ return () +#endif + +-- NOTE: In order to run these tests properly, the following must be true: +-- +-- * They must be run on BeagleBone Black hardware running Linux. +-- * You must have permission to export and unexport pins via the +-- sysfs GPIO filesystem. +-- * You must have permission to write pin attributes via the sysfs +-- GPIO filesystem. +-- * GPIO pins P9-15 (sysfs GPIO pin number 48) and P8-15 (sysfs GPIO +-- pin number 47) must be jumpered together. + +testPin1 :: Pin +testPin1 = Pin 48 + +testPin2 :: Pin +testPin2 = Pin 47 + +invalidPin :: Pin +invalidPin = Pin 9000 + +-- Note: tests which modify pin state have a slight delay between +-- opening the pin and modifying any state. This is so that, if the +-- user running the tests is not root and is using a udev action to +-- change pin ownership (which is the only way at the time of writing +-- to do that), the script has time to run. + +udevScriptWait :: MonadIO m => m () +udevScriptWait = liftIO $ threadDelay 500000 + +runTests :: Spec +runTests = + do + describe "runSysfsGpioIO" $ + do context "pins" $ + it "returns the full list of pins on the system" $ + runSysfsGpioIO pins `shouldReturn` (map Pin [0..127]) + context "openPin/closePin" $ + do it "exports/unexports the pin" $ + runSysfsGpioIO + (do h <- openPin testPin1 + exported <- liftIO $ doesDirectoryExist "/sys/class/gpio/gpio48" + closePin h + stillExported <- liftIO $ doesDirectoryExist "/sys/class/gpio/gpio48" + return (exported, stillExported)) + `shouldReturn` (True, False) + it "openPin doesn't complain if the pin is already exported" $ + runSysfsGpioIO + (withPin testPin1 $ \_ -> + do h <- openPin testPin1 + void $ getPinDirection h + return True) + `shouldReturn` True + it "openPin fails if the pin is invalid" $ + runSysfsGpioIO + (do h <- openPin invalidPin + dir <- getPinDirection h + return dir) + `shouldThrow` isInvalidPinError + it "closePin doesn't complain the pin is already unexported" $ + runSysfsGpioIO + (withPin testPin1 $ \_ -> + do h <- openPin testPin1 + closePin h + closePin h) + `shouldReturn` () + context "withPin" $ + do it "exports/unexports the pin" $ + do runSysfsGpioIO + (withPin testPin1 $ const $ + liftIO $ doesDirectoryExist "/sys/class/gpio/gpio48") + `shouldReturn` True + doesDirectoryExist "/sys/class/gpio/gpio48" `shouldReturn` False + it "unexports the pin upon exception" $ + do runSysfsGpioIO + (withPin testPin1 $ const $ + throwM $ userError "Foo") + `shouldThrow` anyIOException + doesDirectoryExist "/sys/class/gpio/gpio48" `shouldReturn` False + it "handles double-open and double-close gracefully" $ + do runSysfsGpioIO + (withPin testPin1 $ const $ + withPin testPin1 $ const $ + liftIO $ doesDirectoryExist "/sys/class/gpio/gpio48") + `shouldReturn` True + doesDirectoryExist "/sys/class/gpio/gpio48" `shouldReturn` False + it "fails if the pin is invalid" $ + do runSysfsGpioIO + (withPin invalidPin $ const $ + liftIO $ doesDirectoryExist "/sys/class/gpio/gpio9000") + `shouldThrow` isInvalidPinError + context "getPinDirection" $ + do it "gets the pin's direction" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + dir1 <- getPinDirection h + setPinOutputMode h OutputDefault Low + dir2 <- getPinDirection h + setPinInputMode h InputDefault + dir3 <- getPinDirection h + return (dir1, dir2, dir3)) + `shouldReturn` (In, Out, In) + context "getPinInputMode" $ + do it "gets the pin's input mode" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + getPinInputMode h) + `shouldReturn` InputDefault + it "fails when the pin is in output mode" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinOutputMode h OutputDefault Low + getPinInputMode h) + `shouldThrow` isInvalidOperationError + context "setPinInputMode" $ + do it "sets the pin's input mode and direction" $ + do runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + m <- getPinInputMode h + d <- getPinDirection h + return (m,d)) + `shouldReturn` (InputDefault,In) + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinOutputMode h OutputDefault Low + setPinInputMode h InputDefault + m <- getPinInputMode h + d <- getPinDirection h + return (m,d)) + `shouldReturn` (InputDefault,In) + it "fails when the input mode is unsupported" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputPullDown + getPinInputMode h) + `shouldThrow` isUnsupportedInputMode + context "getPinOutputMode" $ + do it "gets the pin's input mode" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinOutputMode h OutputDefault Low + getPinOutputMode h) + `shouldReturn` OutputDefault + it "fails when the pin is in input mode" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + getPinOutputMode h) + `shouldThrow` isInvalidOperationError + context "setPinOutputMode" $ + do it "sets the pin's output mode, direction, and value" $ + do runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault Low + v <- readPin h + m <- getPinOutputMode h + d <- getPinDirection h + return (v,m,d)) + `shouldReturn` (Low,OutputDefault,Out) + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault High + v <- readPin h + m <- getPinOutputMode h + d <- getPinDirection h + return (v,m,d)) + `shouldReturn` (High,OutputDefault,Out) + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinInputMode h InputDefault + setPinOutputMode h OutputDefault High + v <- readPin h + m <- getPinOutputMode h + d <- getPinDirection h + return (v,m,d)) + `shouldReturn` (High,OutputDefault,Out) + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinInputMode h InputDefault + setPinOutputMode h OutputDefault Low + v <- readPin h + m <- getPinOutputMode h + d <- getPinDirection h + return (v,m,d)) + `shouldReturn` (Low,OutputDefault,Out) + it "respects the pin's active level" $ + do runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveLow + setPinOutputMode h OutputDefault Low + setPinActiveLevel h ActiveHigh + v <- readPin h + m <- getPinOutputMode h + d <- getPinDirection h + return (v,m,d)) + `shouldReturn` (High,OutputDefault,Out) + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveLow + setPinOutputMode h OutputDefault High + setPinActiveLevel h ActiveHigh + v <- readPin h + m <- getPinOutputMode h + d <- getPinDirection h + return (v,m,d)) + `shouldReturn` (Low,OutputDefault,Out) + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveLow + setPinInputMode h InputDefault + setPinOutputMode h OutputDefault High + setPinActiveLevel h ActiveHigh + v <- readPin h + m <- getPinOutputMode h + d <- getPinDirection h + return (v,m,d)) + `shouldReturn` (Low,OutputDefault,Out) + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveLow + setPinInputMode h InputDefault + setPinOutputMode h OutputDefault Low + setPinActiveLevel h ActiveHigh + v <- readPin h + m <- getPinOutputMode h + d <- getPinDirection h + return (v,m,d)) + `shouldReturn` (High,OutputDefault,Out) + it "can set the pin's direction to 'Out' when it's configured for edge-triggered reads" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinInterruptMode h RisingEdge + setPinOutputMode h OutputDefault Low + setPinInputMode h InputDefault + setPinInterruptMode h FallingEdge + setPinOutputMode h OutputDefault High + setPinInputMode h InputDefault + setPinInterruptMode h Level + setPinOutputMode h OutputDefault Low + return True) + `shouldReturn` True + it "fails when the output mode is unsupported" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinOutputMode h OutputOpenSourcePullDown Low + getPinInputMode h) + `shouldThrow` isUnsupportedOutputMode + context "getPinActiveLevel/setPinActiveLevel" $ + it "gets and sets the pin's active level" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveLow + level1 <- getPinActiveLevel h + setPinActiveLevel h ActiveHigh + level2 <- getPinActiveLevel h + setPinActiveLevel h ActiveLow + level3 <- getPinActiveLevel h + return (level1, level2, level3)) + `shouldReturn` (ActiveLow, ActiveHigh, ActiveLow) + context "togglePinActiveLevel" $ + it "toggles the pin's active level" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + level1 <- togglePinActiveLevel h + level2 <- togglePinActiveLevel h + level3 <- togglePinActiveLevel h + return (level1, level2, level3)) + `shouldReturn` (ActiveLow, ActiveHigh, ActiveLow) + context "readPin/writePin" $ + -- Note: if these tests fail, you might not have hooked pin + -- P9-15 up to pin P8-15! + do it "reads and writes the pin's value" $ + runSysfsGpioIO + (withPin testPin1 $ \h1 -> + withPin testPin2 $ \h2 -> + do udevScriptWait + setPinInputMode h1 InputDefault + setPinActiveLevel h1 ActiveHigh + setPinActiveLevel h2 ActiveHigh + setPinOutputMode h2 OutputDefault High + -- give the pin time to settle + liftIO $ threadDelay 250000 + val1 <- readPin h1 + writePin h2 Low + liftIO $ threadDelay 250000 + val2 <- readPin h1 + writePin h2 High + liftIO $ threadDelay 250000 + val3 <- readPin h1 + return (val1, val2, val3)) + `shouldReturn` (High, Low, High) + it "readPin obeys the pin's active level" $ + runSysfsGpioIO + (withPin testPin1 $ \h1 -> + withPin testPin2 $ \h2 -> + do udevScriptWait + setPinInputMode h1 InputDefault + setPinActiveLevel h1 ActiveLow + setPinActiveLevel h2 ActiveHigh + setPinOutputMode h2 OutputDefault High + -- give the pin time to settle + liftIO $ threadDelay 250000 + val1 <- readPin h1 + writePin h2 Low + liftIO $ threadDelay 250000 + val2 <- readPin h1 + writePin h2 High + liftIO $ threadDelay 250000 + val3 <- readPin h1 + return (val1, val2, val3)) + `shouldReturn` (Low, High, Low) + it "readPin works on output pins" $ + runSysfsGpioIO + (withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault High + liftIO $ threadDelay 250000 + val1 <- readPin h + writePin h Low + liftIO $ threadDelay 250000 + val2 <- readPin h + writePin h High + liftIO $ threadDelay 250000 + val3 <- readPin h + return (val1, val2, val3)) + `shouldReturn` (High, Low, High) + it "readPin works on output pins (active-low)" $ + runSysfsGpioIO + (withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveLow + setPinOutputMode h OutputDefault High + liftIO $ threadDelay 250000 + val1 <- readPin h + writePin h Low + liftIO $ threadDelay 250000 + val2 <- readPin h + writePin h High + liftIO $ threadDelay 250000 + val3 <- readPin h + return (val1, val2, val3)) + `shouldReturn` (High, Low, High) + it "writePin obeys the pin's active level" $ + runSysfsGpioIO + (withPin testPin1 $ \h1 -> + withPin testPin2 $ \h2 -> + do udevScriptWait + setPinInputMode h1 InputDefault + setPinActiveLevel h1 ActiveHigh + setPinActiveLevel h2 ActiveLow + setPinOutputMode h2 OutputDefault High + -- give the pin time to settle + liftIO $ threadDelay 250000 + val1 <- readPin h1 + writePin h2 Low + liftIO $ threadDelay 250000 + val2 <- readPin h1 + writePin h2 High + liftIO $ threadDelay 250000 + val3 <- readPin h1 + return (val1, val2, val3)) + `shouldReturn` (Low, High, Low) + it "fails if the pin is configured for input" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + writePin h High) + `shouldThrow` isPermissionDeniedError + context "togglePin" $ + -- Note: if these tests fail, you might not have hooked pin + -- P9-15 up to pin P8-15! + do it "toggles the pin's value and returns the previous value" $ + runSysfsGpioIO + (withPin testPin1 $ \h1 -> + withPin testPin2 $ \h2 -> + do udevScriptWait + setPinInputMode h1 InputDefault + setPinActiveLevel h1 ActiveHigh + setPinActiveLevel h2 ActiveHigh + setPinOutputMode h2 OutputDefault Low + h2_val1 <- togglePin h2 + -- give the pin time to settle + liftIO $ threadDelay 250000 + h1_val1 <- readPin h1 + h2_val2 <- togglePin h2 + liftIO $ threadDelay 250000 + h1_val2 <- readPin h1 + h2_val3 <- togglePin h2 + liftIO $ threadDelay 250000 + h1_val3 <- readPin h1 + return (h2_val1, h1_val1, h2_val2, h1_val2, h2_val3, h1_val3)) + `shouldReturn` (High, High, Low, Low, High, High) + it "togglePin obeys the pin's active level" $ + runSysfsGpioIO + (withPin testPin1 $ \h1 -> + withPin testPin2 $ \h2 -> + do udevScriptWait + setPinInputMode h1 InputDefault + setPinActiveLevel h1 ActiveHigh + setPinActiveLevel h2 ActiveLow + setPinOutputMode h2 OutputDefault Low + h2_val1 <- togglePin h2 + -- give the pin time to settle + liftIO $ threadDelay 250000 + h1_val1 <- readPin h1 + h2_val2 <- togglePin h2 + liftIO $ threadDelay 250000 + h1_val2 <- readPin h1 + h2_val3 <- togglePin h2 + liftIO $ threadDelay 250000 + h1_val3 <- readPin h1 + return (h2_val1, h1_val1, h2_val2, h1_val2, h2_val3, h1_val3)) + `shouldReturn` (High, Low, Low, High, High, Low) + it "fails if the pin is configured for input" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + void $ togglePin h) + `shouldThrow` isPermissionDeniedError + context "getPinInterruptMode/setPinInterruptMode" $ + do it "gets and sets the pin's interrupt mode" $ + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinInterruptMode h RisingEdge + trigger1 <- getPinInterruptMode h + setPinInterruptMode h FallingEdge + trigger2 <- getPinInterruptMode h + setPinInterruptMode h Level + trigger3 <- getPinInterruptMode h + setPinInterruptMode h Disabled + trigger4 <- getPinInterruptMode h + return (trigger1, trigger2, trigger3, trigger4)) + `shouldReturn` (RisingEdge, FallingEdge, Level, Disabled) + it "setPinInterruptMode should fail on an output pin" $ + runSysfsGpioIO + (withPin testPin2 $ \h -> + do udevScriptWait + setPinOutputMode h OutputDefault Low + setPinInterruptMode h Level) + `shouldThrow` isInvalidOperationError + context "pollPin" $ + -- Note: if these tests fail, you might not have hooked pin + -- P9-15 up to pin P8-15! + do it "pollPin waits for rising edge" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault High + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveHigh + setPinInterruptMode h RisingEdge + liftIO $ putMVar mvar () + val1 <- pollPin h + val2 <- pollPin h + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2)) + `shouldReturn` (High, High) + it "pollPin waits for falling edge" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault Low + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveHigh + setPinInterruptMode h FallingEdge + liftIO $ putMVar mvar () + val1 <- pollPin h + val2 <- pollPin h + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2)) + `shouldReturn` (Low, Low) + it "pollPin waits for level changes" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault High + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveHigh + setPinInterruptMode h Level + liftIO $ putMVar mvar () + val1 <- pollPin h + val2 <- pollPin h + val3 <- pollPin h + val4 <- pollPin h + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2, val3, val4)) + `shouldReturn` (Low, High, Low, High) + it "pollPin can be disabled" $ + do mvar <- liftIO $ newEmptyMVar + runSysfsGpioIO + (withPin testPin1 $ \inPin -> + withPin testPin2 $ \outPin -> + do udevScriptWait + setPinInputMode inPin InputDefault + setPinActiveLevel inPin ActiveHigh + setPinInterruptMode inPin Disabled + setPinActiveLevel outPin ActiveHigh + setPinOutputMode outPin OutputDefault Low + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + do liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin outPin -- ignored + liftIO $ threadDelay 500000 + setPinInterruptMode inPin Level + void $ togglePin outPin -- trigger + putMVar mvar () -- synchronize finish + liftIO $ putMVar mvar () + val <- pollPin inPin + liftIO $ void $ takeMVar mvar -- synchronize finish + return val) + `shouldReturn` Low + context "pollPin with active-low logic" $ + -- Note: if these tests fail, you might not have hooked pin + -- P9-15 up to pin P8-15! + do it "pollPin waits for (active-low) rising edge" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault Low + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveLow + setPinInterruptMode h RisingEdge + liftIO $ putMVar mvar () + val1 <- pollPin h + val2 <- pollPin h + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2)) + `shouldReturn` (High, High) + it "pollPin waits for (active-low) falling edge" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault High + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveLow + setPinInterruptMode h FallingEdge + liftIO $ putMVar mvar () + val1 <- pollPin h + val2 <- pollPin h + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2)) + `shouldReturn` (Low, Low) + it "pollPin waits for level changes" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault Low + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveLow + setPinInterruptMode h Level + liftIO $ putMVar mvar () + val1 <- pollPin h + val2 <- pollPin h + val3 <- pollPin h + val4 <- pollPin h + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2, val3, val4)) + `shouldReturn` (Low, High, Low, High) + it "pollPin can be disabled" $ + do mvar <- liftIO $ newEmptyMVar + runSysfsGpioIO + (withPin testPin1 $ \inPin -> + withPin testPin2 $ \outPin -> + do udevScriptWait + setPinInputMode inPin InputDefault + setPinActiveLevel inPin ActiveLow + setPinInterruptMode inPin Disabled + setPinActiveLevel outPin ActiveHigh + setPinOutputMode outPin OutputDefault Low + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + do liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin outPin -- ignored + liftIO $ threadDelay 500000 + setPinInterruptMode inPin Level + void $ togglePin outPin -- trigger + putMVar mvar () -- synchronize finish + liftIO $ putMVar mvar () + val <- pollPin inPin + liftIO $ void $ takeMVar mvar -- synchronize finish + return val) + `shouldReturn` High + context "pollPinTimeout" $ + -- Note: if these tests fail, you might not have hooked pin + -- P9-15 up to pin P8-15! + do it "pollPinTimeout waits for rising edge" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault High + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveHigh + setPinInterruptMode h RisingEdge + liftIO $ putMVar mvar () + val1 <- pollPinTimeout h 10000000 + val2 <- pollPinTimeout h 10000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2)) + `shouldReturn` (Just High, Just High) + it "pollPinTimeout waits for falling edge" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault Low + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveHigh + setPinInterruptMode h FallingEdge + liftIO $ putMVar mvar () + val1 <- pollPinTimeout h 10000000 + val2 <- pollPinTimeout h 10000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2)) + `shouldReturn` (Just Low, Just Low) + it "pollPinTimeout waits for level changes" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault High + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveHigh + setPinInterruptMode h Level + liftIO $ putMVar mvar () + val1 <- pollPinTimeout h 10000000 + val2 <- pollPinTimeout h 10000000 + val3 <- pollPinTimeout h 10000000 + val4 <- pollPinTimeout h 10000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2, val3, val4)) + `shouldReturn` (Just Low, Just High, Just Low, Just High) + it "pollPinTimeout can be disabled" $ + do mvar <- liftIO $ newEmptyMVar + runSysfsGpioIO + (withPin testPin1 $ \inPin -> + withPin testPin2 $ \outPin -> + do udevScriptWait + setPinInputMode inPin InputDefault + setPinActiveLevel inPin ActiveHigh + setPinInterruptMode inPin Disabled + setPinActiveLevel outPin ActiveHigh + setPinOutputMode outPin OutputDefault Low + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + do liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin outPin -- ignored + liftIO $ threadDelay 500000 + setPinInterruptMode inPin Level + void $ togglePin outPin -- trigger + putMVar mvar () -- synchronize finish + liftIO $ putMVar mvar () + val <- pollPinTimeout inPin 10000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return val) + `shouldReturn` Just Low + it "pollPinTimeout actually times out" $ + do mvar <- liftIO $ newEmptyMVar + runSysfsGpioIO + (withPin testPin1 $ \inPin -> + withPin testPin2 $ \outPin -> + do udevScriptWait + setPinInputMode inPin InputDefault + setPinActiveLevel inPin ActiveHigh + setPinInterruptMode inPin Disabled + setPinActiveLevel outPin ActiveHigh + setPinOutputMode outPin OutputDefault Low + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + do liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin outPin -- ignored + liftIO $ threadDelay 500000 + void $ togglePin outPin -- ignored + putMVar mvar () -- synchronize finish + liftIO $ putMVar mvar () + val <- pollPinTimeout inPin 1000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return val) + `shouldReturn` Nothing + it "pollPinTimeout times out on output pins" $ + do runSysfsGpioIO + (withPin testPin2 $ \outPin -> + do udevScriptWait + setPinActiveLevel outPin ActiveHigh + setPinOutputMode outPin OutputDefault Low + val <- pollPinTimeout outPin 1000000 + return val) + `shouldReturn` Nothing + context "pollPinTimeout with active-low logic" $ + -- Note: if these tests fail, you might not have hooked pin + -- P9-15 up to pin P8-15! + do it "pollPinTimeout waits for (active-low) rising edge" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault Low + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveLow + setPinInterruptMode h RisingEdge + liftIO $ putMVar mvar () + val1 <- pollPinTimeout h 10000000 + val2 <- pollPinTimeout h 10000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2)) + `shouldReturn` (Just High, Just High) + it "pollPinTimeout waits for (active-low) falling edge" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault High + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveLow + setPinInterruptMode h FallingEdge + liftIO $ putMVar mvar () + val1 <- pollPinTimeout h 10000000 + val2 <- pollPinTimeout h 10000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2)) + `shouldReturn` (Just Low, Just Low) + it "pollPinTimeout waits for level changes" $ + do mvar <- liftIO $ newEmptyMVar + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + withPin testPin2 $ \h -> + do udevScriptWait + setPinActiveLevel h ActiveHigh + setPinOutputMode h OutputDefault Low + liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + liftIO $ threadDelay 500000 + void $ togglePin h -- trigger + putMVar mvar () -- synchronize finish + runSysfsGpioIO + (withPin testPin1 $ \h -> + do udevScriptWait + setPinInputMode h InputDefault + setPinActiveLevel h ActiveLow + setPinInterruptMode h Level + liftIO $ putMVar mvar () + val1 <- pollPinTimeout h 10000000 + val2 <- pollPinTimeout h 10000000 + val3 <- pollPinTimeout h 10000000 + val4 <- pollPinTimeout h 10000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return (val1, val2, val3, val4)) + `shouldReturn` (Just Low, Just High, Just Low, Just High) + it "pollPinTimeout can be disabled" $ + do mvar <- liftIO $ newEmptyMVar + runSysfsGpioIO + (withPin testPin1 $ \inPin -> + withPin testPin2 $ \outPin -> + do udevScriptWait + setPinInputMode inPin InputDefault + setPinActiveLevel inPin ActiveLow + setPinInterruptMode inPin Disabled + setPinActiveLevel outPin ActiveHigh + setPinOutputMode outPin OutputDefault Low + void $ liftIO $ forkIO $ + do runSysfsGpioIO $ + do liftIO $ void $ takeMVar mvar + liftIO $ threadDelay 500000 + void $ togglePin outPin -- ignored + liftIO $ threadDelay 500000 + setPinInterruptMode inPin Level + void $ togglePin outPin -- trigger + putMVar mvar () -- synchronize finish + liftIO $ putMVar mvar () + val <- pollPinTimeout inPin 10000000 + liftIO $ void $ takeMVar mvar -- synchronize finish + return val) + `shouldReturn` Just High + context "Various NotExported exceptions" $ + do it "getPinDirection" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + v <- getPinDirection h + return v) + `shouldThrow` isNotExportedError + it "getPinInputMode" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + getPinInputMode h) + `shouldThrow` isNotExportedError + it "setPinInputMode" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + setPinInputMode h InputDefault) + `shouldThrow` isNotExportedError + it "getPinOutputMode" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + getPinOutputMode h) + `shouldThrow` isNotExportedError + it "setPinOutputMode" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + setPinOutputMode h OutputDefault Low) + `shouldThrow` isNotExportedError + it "getPinInterruptMode" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + v <- getPinInterruptMode h + return v) + `shouldThrow` isNotExportedError + it "setPinInterruptMode" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + setPinInterruptMode h RisingEdge) + `shouldThrow` isNotExportedError + it "getPinActiveLevel" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + v <- getPinActiveLevel h + return v) + `shouldThrow` isNotExportedError + it "setPinActiveLevel" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + setPinActiveLevel h ActiveHigh) + `shouldThrow` isNotExportedError + it "toggleActiveLevel" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + v <- togglePinActiveLevel h + return v) + `shouldThrow` isNotExportedError + it "readPin" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + v <- readPin h + return v) + `shouldThrow` isNotExportedError + it "pollPin" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + v <- pollPin h + return v) + `shouldThrow` isNotExportedError + it "pollPinTimeout" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + v <- pollPinTimeout h 100000 + return v) + `shouldThrow` isNotExportedError + it "writePin" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + writePin h High) + `shouldThrow` isNotExportedError + it "togglePin" $ + runSysfsGpioIO + (do h <- openPin testPin1 + closePin h + v <- togglePin h + return v) + `shouldThrow` isNotExportedError diff --git a/test/Test/System/GPIO/Linux/Sysfs/MockInternalSpec.hs b/test/Test/System/GPIO/Linux/Sysfs/MockInternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/System/GPIO/Linux/Sysfs/MockInternalSpec.hs @@ -0,0 +1,331 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-incomplete-uni-patterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.System.GPIO.Linux.Sysfs.MockInternalSpec (spec) where + +import Protolude +import GHC.IO.Exception (IOErrorType(..)) +import System.GPIO.Linux.Sysfs.Mock.Internal +import System.IO.Error + (IOError, ioeGetErrorType, isAlreadyExistsError, + isDoesNotExistError) +import Test.Hspec + +isInvalidArgumentErrorType :: IOErrorType -> Bool +isInvalidArgumentErrorType InvalidArgument = True +isInvalidArgumentErrorType _ = False + +isInvalidArgumentError :: IOError -> Bool +isInvalidArgumentError = isInvalidArgumentErrorType . ioeGetErrorType + +isInappropriateTypeErrorType :: IOErrorType -> Bool +isInappropriateTypeErrorType InappropriateType = True +isInappropriateTypeErrorType _ = False + +isInappropriateTypeError :: IOError -> Bool +isInappropriateTypeError = isInappropriateTypeErrorType . ioeGetErrorType + +sysfsRoot :: Directory +sysfsRoot = + directory "/" + [] + [directory "sys" + [] + [directory "class" + [] + [directory "gpio" + [File "export" Export + ,File "unexport" Unexport] + []]]] + +parentName :: MockFSCrumb -> Name +parentName = _dirNodeName . _node + +spec :: Spec +spec = + let sysfsRootZ = MockFSZipper sysfsRoot [] + in + do describe "cd" $ do + + context "relative paths" $ do + + it "can traverse downwards one directory at a time" $ + do let Right z1@(MockFSZipper dir1 (crumb1:_)) = cd "sys" sysfsRootZ + dirName dir1 `shouldBe` "sys" + parentName crumb1 `shouldBe` "/" + let Right z2@(MockFSZipper dir2 (crumb2:_)) = cd "class" z1 + dirName dir2 `shouldBe` "class" + parentName crumb2 `shouldBe` "sys" + let Right (MockFSZipper dir3 (crumb3:_)) = cd "gpio" z2 + dirName dir3 `shouldBe` "gpio" + parentName crumb3 `shouldBe` "class" + + it "can traverse downwards multiple directories at a time" $ + do let Right (MockFSZipper dir1 (crumb1:_)) = cd "sys/class/gpio" sysfsRootZ + dirName dir1 `shouldBe` "gpio" + parentName crumb1 `shouldBe` "class" + + it "fails when changing to a non-existent child" $ + do let Left result1 = cd "foobar" sysfsRootZ + isDoesNotExistError result1 `shouldBe` True + let Left result2 = (cd "sys/class" sysfsRootZ >>= cd "baz" ) + isDoesNotExistError result2 `shouldBe` True + + it "fails when changing to a non-existent grandchild" $ + do let Left result = cd "sys/class/foobar" sysfsRootZ + isDoesNotExistError result `shouldBe` True + + it "fails when changing to a file name rather than a directory name" $ + do let Left result1 = (cd "sys/class/gpio" sysfsRootZ >>= cd "export") + isInappropriateTypeError result1 `shouldBe` True + let Left result2 = (cd "sys/class/gpio" sysfsRootZ >>= cd "export/foobar") + isInappropriateTypeError result2 `shouldBe` True + let Left result3 = cd "sys/class/gpio/unexport" sysfsRootZ + isInappropriateTypeError result3 `shouldBe` True + let Left result4 = cd "sys/class/gpio/unexport/baz" sysfsRootZ + isInappropriateTypeError result4 `shouldBe` True + + it "'.' in paths" $ + do cd "sys/." sysfsRootZ `shouldBe` cd "sys" sysfsRootZ + cd "sys/./class" sysfsRootZ `shouldBe` cd "sys/class" sysfsRootZ + + it "'..' in paths" $ + do cd "sys/.." sysfsRootZ `shouldBe` Right sysfsRootZ + cd "sys/class/../class" sysfsRootZ `shouldBe` cd "sys/class" sysfsRootZ + cd "sys/class/gpio/../../class" sysfsRootZ `shouldBe` cd "sys/../sys/class/../class/gpio/.." sysfsRootZ + cd "sys/class/gpio/../../.." sysfsRootZ `shouldBe` Right sysfsRootZ + + it "'..' beyond root clamps to root" $ + do cd "sys/class/../../../.." sysfsRootZ `shouldBe` Right sysfsRootZ + cd "../.." sysfsRootZ `shouldBe` Right sysfsRootZ + + context "absolute paths" $ do + it "can traverse downwards one directory at a time" $ + do let Right z1@(MockFSZipper dir1 (crumb1:_)) = cd "/sys" sysfsRootZ + dirName dir1 `shouldBe` "sys" + parentName crumb1 `shouldBe` "/" + let Right z2@(MockFSZipper dir2 (crumb2:_)) = cd "class" z1 + dirName dir2 `shouldBe` "class" + parentName crumb2 `shouldBe` "sys" + let Right (MockFSZipper dir3 (crumb3:_)) = cd "gpio" z2 + dirName dir3 `shouldBe` "gpio" + parentName crumb3 `shouldBe` "class" + it "can traverse downwards multiple directories at a time" $ + do let Right (MockFSZipper dir1 (crumb1:_)) = cd "/sys/class/gpio" sysfsRootZ + dirName dir1 `shouldBe` "gpio" + parentName crumb1 `shouldBe` "class" + it "fails when changing to a non-existent child" $ + do let Left result = cd "/foobar" sysfsRootZ + isDoesNotExistError result `shouldBe` True + it "fails when changing to a non-existent grandchild" $ + do let Left result = cd "/sys/class/foobar" sysfsRootZ + isDoesNotExistError result `shouldBe` True + it "fails when changing to a file name rather than a directory name" $ + do let Left result1 = cd "/sys/class/gpio/export" sysfsRootZ + isInappropriateTypeError result1 `shouldBe` True + let Left result2 = cd "/sys/class/gpio/unexport/baz" sysfsRootZ + isInappropriateTypeError result2 `shouldBe` True + + it "cd / is root" $ + cd "/" sysfsRootZ `shouldBe` Right sysfsRootZ + + it "cd / from deeper starts at root" $ do + (cd "/sys/class/gpio" sysfsRootZ >>= cd "/") `shouldBe` Right sysfsRootZ + (cd "/sys/class/gpio" sysfsRootZ >>= cd "/sys/class") `shouldBe` cd "/sys/class" sysfsRootZ + + it "'.' in paths" $ + do cd "/sys/." sysfsRootZ `shouldBe` cd "/sys" sysfsRootZ + cd "/sys/./class" sysfsRootZ `shouldBe` cd "/sys/class" sysfsRootZ + it "'..' in paths" $ + do cd "/sys/.." sysfsRootZ `shouldBe` Right sysfsRootZ + cd "/sys/class/../class" sysfsRootZ `shouldBe` cd "/sys/class" sysfsRootZ + cd "/sys/class/gpio/../../class" sysfsRootZ `shouldBe` cd "/sys/../sys/class/../class/gpio/.." sysfsRootZ + cd "/sys/class/gpio/../../.." sysfsRootZ `shouldBe` Right sysfsRootZ + it "'..' beyond root clamps to root" $ + do cd "/sys/class/../../../.." sysfsRootZ `shouldBe` Right sysfsRootZ + cd "/../.." sysfsRootZ `shouldBe` Right sysfsRootZ + + context "absolute and relative paths" $ do + it "produce the same result when they lead to the same directory" $ + do cd "sys/class/gpio" sysfsRootZ `shouldBe` cd "/sys/class/gpio" sysfsRootZ + cd "sys/class/gpio/.." sysfsRootZ `shouldBe` cd "/sys/class/gpio/.." sysfsRootZ + cd "sys/class/gpio/../../." sysfsRootZ `shouldBe` cd "/sys/class/gpio/../../." sysfsRootZ + cd "sys/class/.././class/../../sys" sysfsRootZ `shouldBe` cd "/sys/../sys/class/./gpio/../.." sysfsRootZ + + describe "mkdir" $ + do it "creates a subdirectory in the current directory" $ + do let Right z1@(MockFSZipper dir1 crumb1) = mkdir "xyzzy" sysfsRootZ + dirName dir1 `shouldBe` "/" + crumb1 `shouldBe` [] + let Right (MockFSZipper dir2 (crumb2:_)) = cd "xyzzy" z1 + dirName dir2 `shouldBe` "xyzzy" + parentName crumb2 `shouldBe` "/" + + it "can create multiple subdirectories in the same directory" $ + do let Right z1@(MockFSZipper dir1 crumb1) = mkdir "xyzzy" sysfsRootZ + dirName dir1 `shouldBe` "/" + crumb1 `shouldBe` [] + let Right z2@(MockFSZipper dir2 crumb2) = mkdir "plugh" z1 + dirName dir2 `shouldBe` "/" + crumb2 `shouldBe` [] + let Right z3@(MockFSZipper dir3 (crumb3:_)) = cd "xyzzy" z2 + dirName dir3 `shouldBe` "xyzzy" + parentName crumb3 `shouldBe` "/" + let Right (MockFSZipper dir4 (crumb4:_)) = cd "../plugh" z3 + dirName dir4 `shouldBe` "plugh" + parentName crumb4 `shouldBe` "/" + + it "works when nested" $ + do let Right (MockFSZipper dir (crumb:_)) = mkdir "abc" sysfsRootZ >>= cd "/abc" >>= mkdir "def" >>= cd "/abc/def" + dirName dir `shouldBe` "def" + parentName crumb `shouldBe` "abc" + + it "fails when a subdir with the same name already exists" $ + do let Left result = mkdir "sys" sysfsRootZ + isAlreadyExistsError result `shouldBe` True + + it "fails when a file with the same name already exists" $ + do let Left result = (cd "/sys/class/gpio" sysfsRootZ >>= mkdir "export") + isAlreadyExistsError result `shouldBe` True + + it "fails with an invalid name" $ + do let Left result = mkdir "" sysfsRootZ + isInvalidArgumentError result `shouldBe` True + + it "fails when the name contains a '/'" $ + do let Left result1 = mkdir "/abc" sysfsRootZ + isInvalidArgumentError result1 `shouldBe` True + let Left result2 = mkdir "sys/foobar" sysfsRootZ + isInvalidArgumentError result2 `shouldBe` True + + describe "mkfile" $ + do it "creates a file in the current directory when clobber is False" $ + do let Right z1 = cd "/sys/class/gpio" sysfsRootZ + let Right (MockFSZipper dir2 (crumb2:_)) = mkfile "gpio1" (Constant ["Hey!", "This is gpio1"]) False z1 + dirName dir2 `shouldBe` "gpio" + parentName crumb2 `shouldBe` "class" + let file:rest = files dir2 + _fileName file `shouldBe` "gpio1" + _fileType file `shouldBe` (Constant ["Hey!", "This is gpio1"]) + rest `shouldBe` [File {_fileName = "export", _fileType = Export},File {_fileName = "unexport", _fileType = Unexport}] + + it "creates a file in the current directory when clobber is True" $ + do let Right z1 = cd "/sys/class/gpio" sysfsRootZ + let Right (MockFSZipper dir2 (crumb2:_)) = mkfile "gpio1" (Constant ["Hey!", "This is gpio1"]) True z1 + dirName dir2 `shouldBe` "gpio" + parentName crumb2 `shouldBe` "class" + let file:rest = files dir2 + _fileName file `shouldBe` "gpio1" + _fileType file `shouldBe` (Constant ["Hey!", "This is gpio1"]) + rest `shouldBe` [File {_fileName = "export", _fileType = Export},File {_fileName = "unexport", _fileType = Unexport}] + + it "fails when a subdir with the same name already exists" $ do + let Left result1 = mkfile "sys" (Constant []) True sysfsRootZ + isAlreadyExistsError result1 `shouldBe` True + let Left result2 = mkfile "sys" (Constant []) False sysfsRootZ + isAlreadyExistsError result2 `shouldBe` True + + it "fails when a file with the same name already exists and clobber is False" $ + do let Left result = (cd "/sys/class/gpio" sysfsRootZ >>= mkfile "export" (Constant []) False) + isAlreadyExistsError result `shouldBe` True + + it "overwrites an existing file's contents when a file with the same name already exists and clobber is True" $ + do let Right z1 = cd "/sys/class/gpio" sysfsRootZ + let Right z2 = mkfile "gpio1" (Constant ["Hey!", "This is gpio1"]) False z1 + let Right (MockFSZipper dir3 (crumb3:_)) = mkfile "gpio1" (Constant ["Hey!", "Now I'm gpio1"]) True z2 + dirName dir3 `shouldBe` "gpio" + parentName crumb3 `shouldBe` "class" + let file:rest = files dir3 + _fileName file `shouldBe` "gpio1" + _fileType file `shouldBe` (Constant ["Hey!", "Now I'm gpio1"]) + rest `shouldBe` [File {_fileName = "export", _fileType = Export},File {_fileName = "unexport", _fileType = Unexport}] + + it "fails with an invalid name" $ do + let Left result1 = mkfile "" (Constant []) False sysfsRootZ + isInvalidArgumentError result1 `shouldBe` True + let Left result2 = mkfile "" (Constant []) True sysfsRootZ + isInvalidArgumentError result2 `shouldBe` True + + it "fails when the name contains a '/'" $ + do let Left result1 = mkfile "/abc" (Constant []) False sysfsRootZ + isInvalidArgumentError result1 `shouldBe` True + let Left result2 = mkfile "/abc" (Constant []) True sysfsRootZ + isInvalidArgumentError result2 `shouldBe` True + let Left result3 = mkfile "sys/foobar" (Constant []) False sysfsRootZ + isInvalidArgumentError result3 `shouldBe` True + let Left result4 = mkfile "sys/foobar" (Constant []) True sysfsRootZ + isInvalidArgumentError result4 `shouldBe` True + + describe "findFile" $ + do it "finds files in the current directory" $ + do let Right z1@(MockFSZipper dir1 _) = cd "/sys/class/gpio" sysfsRootZ + findFile "export" dir1 `shouldBe` (Just Export) + findFile "unexport" dir1 `shouldBe` (Just Unexport) + let Right (MockFSZipper dir2 _) = mkfile "gpio1" (Constant ["Hey!", "This is gpio1"]) False z1 + findFile "gpio1" dir2 `shouldBe` (Just ((Constant ["Hey!", "This is gpio1"]))) + it "doesn't find subdirectories in the current directory" $ + do let Right (MockFSZipper dir1 _) = cd "/sys/class" sysfsRootZ + findFile "gpio" dir1 `shouldBe` Nothing + it "returns failure on non-existent files" $ + do let Right (MockFSZipper dir1 _) = cd "/sys/class" sysfsRootZ + findFile "foobar" dir1 `shouldBe` Nothing + findFile "export" dir1 `shouldBe` Nothing + it "doesn't find files in subdirectories of the current directory" $ + do let Right (MockFSZipper dir1 _) = cd "/sys/class" sysfsRootZ + findFile "gpio/export" dir1 `shouldBe` Nothing + + describe "rmdir" $ + do it "removes a subdirectory of the current directory" $ + do let Right z1 = cd "/sys" sysfsRootZ >>= mkdir "xyzzy" >>= mkdir "plugh" + let Right z2@(MockFSZipper dir2 (crumb2:_)) = rmdir "xyzzy" z1 + dirName dir2 `shouldBe` "sys" + parentName crumb2 `shouldBe` "/" + let Right (MockFSZipper dir3 (crumb3:_)) = rmdir "plugh" z2 + dirName dir3 `shouldBe` "sys" + parentName crumb3 `shouldBe` "/" + + it "fails when no subdir with the name exists" $ + do let Left result = rmdir "foo" sysfsRootZ + isDoesNotExistError result `shouldBe` True + + it "fails when a file is named" $ + do let Left result = (cd "/sys/class/gpio" sysfsRootZ >>= rmdir "export") + isInappropriateTypeError result `shouldBe` True + + it "fails when the name contains a '/'" $ + do let Left result1 = rmdir "/sys" sysfsRootZ + isDoesNotExistError result1 `shouldBe` True + let Left result2 = rmdir "sys/class" sysfsRootZ + isDoesNotExistError result2 `shouldBe` True + + describe "rmfile" $ + do it "removes a file in the current directory" $ + do let Right z1 = cd "/sys" sysfsRootZ >>= mkfile "abc" (Constant []) False >>= mkfile "def" (Constant []) False + let Right z2@(MockFSZipper dir2 (crumb2:_)) = rmfile "abc" z1 + dirName dir2 `shouldBe` "sys" + parentName crumb2 `shouldBe` "/" + files dir2 `shouldBe` [File {_fileName = "def", _fileType = (Constant [])}] + let Right (MockFSZipper dir3 (crumb3:_)) = rmfile "def" z2 + dirName dir3 `shouldBe` "sys" + parentName crumb3 `shouldBe` "/" + files dir3 `shouldBe` [] + + it "fails when no file with the name exists" $ + do let Left result = rmfile "foo" sysfsRootZ + isDoesNotExistError result `shouldBe` True + + it "fails when a directory is named" $ + do let Left result = (cd "/sys/class" sysfsRootZ >>= rmfile "gpio") + isInappropriateTypeError result `shouldBe` True + + it "fails when the name contains a '/'" $ + do let Left result = rmfile "/sys/class/gpio/export" sysfsRootZ + isDoesNotExistError result `shouldBe` True + + describe "pathFromRoot" $ + do it "returns the path from the current directory to the root directory" $ + do pathFromRoot sysfsRootZ `shouldBe` "/" + let Right z1 = cd "/sys/class/gpio" sysfsRootZ + pathFromRoot z1 `shouldBe` "/sys/class/gpio" + let Right z2 = cd "/sys/class/gpio/../../class" sysfsRootZ + pathFromRoot z2 `shouldBe` "/sys/class" diff --git a/test/Test/System/GPIO/Linux/Sysfs/MockSpec.hs b/test/Test/System/GPIO/Linux/Sysfs/MockSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/System/GPIO/Linux/Sysfs/MockSpec.hs @@ -0,0 +1,137 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-incomplete-uni-patterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.System.GPIO.Linux.Sysfs.MockSpec (spec) where + +import Protolude hiding (readFile, writeFile) +import GHC.IO.Exception (IOErrorType(..)) +import System.GPIO.Linux.Sysfs.Mock +import System.GPIO.Types (Pin(..), PinValue(..)) +import System.IO.Error + (IOError, ioeGetErrorType, isDoesNotExistError, isPermissionError) +import Test.Hspec + +isInappropriateTypeErrorType :: IOErrorType -> Bool +isInappropriateTypeErrorType InappropriateType = True +isInappropriateTypeErrorType _ = False + +isInappropriateTypeError :: IOError -> Bool +isInappropriateTypeError = isInappropriateTypeErrorType . ioeGetErrorType + +evalSysfsMock' :: SysfsMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe IOError) a +evalSysfsMock' a w c = either (Left . fromException) Right $ evalSysfsMock a w c + +evalSysfsMockME :: SysfsMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe MockFSException) a +evalSysfsMockME a w c = either (Left . fromException) Right $ evalSysfsMock a w c + +execSysfsMock' :: SysfsMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe IOError) MockWorld +execSysfsMock' a w c = either (Left . fromException) Right $ execSysfsMock a w c + +spec :: Spec +spec = + do + describe "MockPinState" $ do + it "logicalValue returns the correct pin value" $ + let pinState = defaultMockPinState {_value = Low, _activeLow = False} + in do + logicalValue pinState `shouldBe` Low + logicalValue (pinState {_value = High}) `shouldBe` High + logicalValue (pinState {_activeLow = True}) `shouldBe` High + logicalValue (pinState {_value = High, _activeLow = True}) `shouldBe` Low + it "setLogicalValue sets the correct pin value" $ + let pinState = defaultMockPinState {_value = Low, _activeLow = False} + activeLowPinState = defaultMockPinState {_value = Low, _activeLow = True} + in do + setLogicalValue Low pinState `shouldBe` pinState + setLogicalValue High pinState `shouldBe` pinState {_value = High} + setLogicalValue Low activeLowPinState `shouldBe` activeLowPinState {_value = High} + setLogicalValue High activeLowPinState `shouldBe` activeLowPinState {_value = Low} + + describe "SysfsMockT" $ do + + context "doesDirectoryExist" $ do + it "relative paths are relative to the initial zipper's working directory" $ do + evalSysfsMock' (doesDirectoryExist "sys/class/gpio") initialMockWorld [] `shouldBe` Right True + it "absolute paths work regardless of the initial zipper's working directory" $ do + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio") initialMockWorld [] `shouldBe` Right True + it "doesn't change the initial zipper's state" $ do + execSysfsMock' (doesDirectoryExist "/sys/class/gpio") initialMockWorld [] `shouldBe` Right initialMockWorld + it "returns False on files" $ do + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/export") initialMockWorld [] `shouldBe` Right False + it "returns False on non-existent names" $ do + evalSysfsMock' (doesDirectoryExist "/sys/class/foobar") initialMockWorld [] `shouldBe` Right False + + context "doesFileExist" $ do + it "relative paths are relative to the initial zipper's working directory" $ do + evalSysfsMock' (doesFileExist "sys/class/gpio/export") initialMockWorld [] `shouldBe` Right True + it "absolute paths work regardless of the initial zipper's working directory" $ do + evalSysfsMock' (doesFileExist "/sys/class/gpio/export") initialMockWorld [] `shouldBe` Right True + it "doesn't change the initial zipper's state" $ do + execSysfsMock' (doesFileExist "/sys/class/gpio/export") initialMockWorld [] `shouldBe` Right initialMockWorld + it "returns False on directories" $ do + evalSysfsMock' (doesFileExist "/sys/class/gpio") initialMockWorld [] `shouldBe` Right False + it "returns False on non-existent names" $ do + evalSysfsMock' (doesFileExist "/sys/class/foobar") initialMockWorld [] `shouldBe` Right False + + context "getDirectoryContents" $ do + it "relative paths are relative to the initial zipper's working directory" $ do + fmap sort (evalSysfsMock' (getDirectoryContents "sys/class") initialMockWorld []) `shouldBe` Right ["gpio"] + fmap sort (evalSysfsMock' (getDirectoryContents "sys/class/gpio") initialMockWorld []) `shouldBe` (Right $ sort ["export", "unexport"]) + it "absolute paths work regardless of the initial zipper's working directory" $ do + fmap sort (evalSysfsMock' (getDirectoryContents "/sys/class") initialMockWorld []) `shouldBe` Right ["gpio"] + fmap sort (evalSysfsMock' (getDirectoryContents "/sys/class/gpio") initialMockWorld []) `shouldBe` (Right $ sort ["export", "unexport"]) + it "doesn't change the initial zipper's state" $ do + execSysfsMock' (getDirectoryContents "/sys/class/gpio") initialMockWorld [] `shouldBe` Right initialMockWorld + it "returns failure on files" $ do + do let Left (Just result) = evalSysfsMock' (getDirectoryContents "/sys/class/gpio/export") initialMockWorld [] + isInappropriateTypeError result `shouldBe` True + it "returns failure on non-existent names" $ do + do let Left (Just result) = evalSysfsMock' (getDirectoryContents "/sys/class/foobar") initialMockWorld [] + isDoesNotExistError result `shouldBe` True + + context "readFile" $ do + -- Note: most interesting cases are already checked by the + -- tests in 'SysfsGpioMockSpec.hs' and it would be a bit silly + -- to try to test them here due to the amount of setup + -- required to get the filesystem into the necessary state. + -- (We would basically end up rewriting large chunks of the + -- mock GPIO code.) + it "works with 'constant' files" $ + let chip0 = MockGpioChip "chip0" 0 (replicate 16 defaultMockPinState) + in evalSysfsMock' (readFile "/sys/class/gpio/gpiochip0/base") initialMockWorld [chip0] `shouldBe` Right "0\n" + it "fails on /sys/class/gpio/export" $ + do let Left (Just result) = evalSysfsMock' (readFile "/sys/class/gpio/export") initialMockWorld [] + isPermissionError result `shouldBe` True + it "fails on /sys/class/gpio/unexport" $ + do let Left (Just result) = evalSysfsMock' (readFile "/sys/class/gpio/unexport") initialMockWorld [] + isPermissionError result `shouldBe` True + it "fails on non-existent file" $ + do let Left (Just result) = evalSysfsMock' (readFile "/sys/class/gpio/foo") initialMockWorld [] + isDoesNotExistError result `shouldBe` True + it "fails on a directory" $ + do let Left (Just result) = evalSysfsMock' (readFile "/sys/class/gpio") initialMockWorld [] + isInappropriateTypeError result `shouldBe` True + + context "writeFile" $ + it "does the right thing" $ + pendingWith "Not implemented" -- See notes for 'readFile' + -- above. + + context "runSysfsMockT" $ do + let chip0 = MockGpioChip "chip0" 0 (replicate 16 defaultMockPinState) + chip16 = MockGpioChip "xyz" 16 (replicate 32 defaultMockPinState) + chip64 = MockGpioChip "abc" 64 (replicate 16 defaultMockPinState) + invalidChip32 = MockGpioChip "invalid" 32 (replicate 16 defaultMockPinState) + it "creates the specified gpiochip directories" $ do + fmap sort (evalSysfsMock' (getDirectoryContents "/sys/class/gpio") initialMockWorld [chip0, chip16, chip64]) `shouldBe` Right ["export", "gpiochip0", "gpiochip16", "gpiochip64", "unexport"] + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip0/base") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "0\n" + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip0/ngpio") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "16\n" + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip0/label") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "chip0\n" + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip16/base") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "16\n" + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip16/ngpio") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "32\n" + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip16/label") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "xyz\n" + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip64/base") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "64\n" + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip64/ngpio") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "16\n" + evalSysfsMock' (readFile "/sys/class/gpio/gpiochip64/label") initialMockWorld [chip0, chip16, chip64] `shouldBe` Right "abc\n" + it "fails when MockGpioChips overlap" $ do + evalSysfsMockME (readFile "/sys/class/gpio/gpiochip16/ngpio") initialMockWorld [chip0, chip16, invalidChip32] `shouldBe` Left (Just $ GpioChipOverlap $ Pin 47) diff --git a/test/Test/System/GPIO/Linux/Sysfs/SysfsGpioMockSpec.hs b/test/Test/System/GPIO/Linux/Sysfs/SysfsGpioMockSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/System/GPIO/Linux/Sysfs/SysfsGpioMockSpec.hs @@ -0,0 +1,878 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-incomplete-uni-patterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.System.GPIO.Linux.Sysfs.SysfsGpioMockSpec (spec) where + +import Protolude hiding (handle) +import Control.Monad.Catch (MonadCatch, MonadMask, handle) +import qualified Data.Map.Strict as Map (lookup) +import qualified Data.Set as Set (empty, fromList) + +import System.GPIO.Linux.Sysfs.Mock +import System.GPIO.Linux.Sysfs.Types (SysfsEdge(..), SysfsException(..)) +import System.GPIO.Monad + +import Test.Hspec + +-- To some extent, these tests only test the implementation of the +-- Mock interpreter, which isn't particularly valuable on its own. +-- However, it does allow us to test that we're able to express the +-- kinds of GpioT programs we want, in a pure environment (and when +-- the platform we're developing on doesn't actually have GPIO +-- functionality). + +testOpenClose :: (MonadGpio h m) => m () +testOpenClose = + do h <- openPin (Pin 1) + closePin h + +testSetInterruptMode :: (MonadGpio h m) => m (PinInterruptMode, PinInterruptMode, PinInterruptMode, PinInterruptMode) +testSetInterruptMode = + do d <- openPin (Pin 1) + setPinInputMode d InputDefault + setPinInterruptMode d Disabled + t1 <- getPinInterruptMode d + setPinInterruptMode d RisingEdge + t2 <- getPinInterruptMode d + setPinInterruptMode d FallingEdge + t3 <- getPinInterruptMode d + setPinInterruptMode d Level + t4 <- getPinInterruptMode d + closePin d + return (t1, t2, t3, t4) + +testSetInterruptModeIdempotent :: (MonadGpio h m) => m (PinInterruptMode, PinInterruptMode) +testSetInterruptModeIdempotent = + do d <- openPin (Pin 1) + setPinInputMode d InputDefault + setPinInterruptMode d FallingEdge + t1 <- getPinInterruptMode d + setPinInterruptMode d FallingEdge + t2 <- getPinInterruptMode d + closePin d + return (t1, t2) + +testReadWritePin :: (MonadGpio h m) => h -> m (PinValue, PinValue, PinValue) +testReadWritePin d = + do val1 <- readPin d + case val1 of + Low -> + do writePin d High + val2 <- readPin d + writePin d Low + val3 <- readPin d + return (val1,val2,val3) + High -> + do writePin d Low + val2 <- readPin d + writePin d High + val3 <- readPin d + return (val1,val2,val3) + +testReadWritePinIdempotent :: (MonadGpio h m) => m (PinValue, PinValue) +testReadWritePinIdempotent = + do d <- openPin (Pin 1) + setPinOutputMode d OutputDefault Low + val1 <- readPin d + case val1 of + Low -> + do writePin d Low + val2 <- readPin d + closePin d + return (val1,val2) + High -> + do writePin d High + val2 <- readPin d + closePin d + return (val1,val2) + +testWritePinFailsOnInputPin :: (MonadGpio h m) => m () +testWritePinFailsOnInputPin = + do d <- openPin (Pin 1) + setPinInputMode d InputDefault + writePin d High + closePin d + +testTogglePinValue :: (MonadGpio h m) => m (PinValue, PinValue, PinValue, PinValue, PinValue) +testTogglePinValue = + do d <- openPin (Pin 1) + setPinOutputMode d OutputDefault Low + val1 <- readPin d + val2 <- togglePin d + val3 <- readPin d + val4 <- togglePin d + val5 <- readPin d + closePin d + return (val1, val2, val3, val4, val5) + +testTogglePinActiveLevel :: (MonadGpio h m) => h -> m (PinActiveLevel, PinActiveLevel, PinActiveLevel, PinActiveLevel, PinActiveLevel) +testTogglePinActiveLevel h = + do val1 <- getPinActiveLevel h + val2 <- togglePinActiveLevel h + val3 <- getPinActiveLevel h + val4 <- togglePinActiveLevel h + val5 <- getPinActiveLevel h + return (val1, val2, val3, val4, val5) + +invalidHandle :: (MonadGpio h m) => (h -> m a) -> m a +invalidHandle action = + do d <- openPin (Pin 1) + closePin d + action d + +testWithPin :: (MonadGpio h m, MonadMask m) => m PinValue +testWithPin = withPin (Pin 1) $ \h -> + do setPinOutputMode h OutputDefault Low + writePin h High + val <- readPin h + return val + +testNestedWithPin :: (MonadGpio h m, MonadMask m) => Pin -> Pin -> m (PinValue, PinValue) +testNestedWithPin p1 p2 = + withPin p1 $ \h1 -> + withPin p2 $ \h2 -> + do setPinOutputMode h1 OutputDefault Low + setPinOutputMode h2 OutputDefault Low + writePin h1 High + writePin h2 Low + val1 <- readPin h1 + val2 <- readPin h2 + return (val1, val2) + +handleGpioException :: MonadCatch m => (SomeGpioException -> m a) -> m a -> m a +handleGpioException = handle + +testWithPinError :: (MonadGpio h m, MonadMask m, MonadCatch m) => Pin -> Pin -> m (Maybe PinValue) +testWithPinError p1 p2 = handleGpioException (const $ return Nothing) $ + withPin p1 $ \h1 -> + withPin p2 $ \h2 -> + do setPinOutputMode h1 OutputDefault Low + setPinInputMode h2 InputDefault + writePin h1 High -- should fail if p1 == p2 + writePin h2 Low -- should fail in any case + val1 <- readPin h1 + return $ Just val1 + +chip0 :: MockGpioChip +chip0 = MockGpioChip "chip0" 0 (replicate 16 defaultMockPinState) + +chip1 :: MockGpioChip +chip1 = MockGpioChip "chip1" 32 (replicate 32 defaultMockPinState) + +evalSysfsGpioMock' :: SysfsGpioMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe SysfsException) a +evalSysfsGpioMock' a w c = either (Left . fromException) return $ evalSysfsGpioMock a w c + +execSysfsGpioMock' :: SysfsGpioMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe SysfsException) MockWorld +execSysfsGpioMock' a w c = either (Left . fromException) return $ execSysfsGpioMock a w c + +runSysfsGpioMock' :: SysfsGpioMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe SysfsException) (a, MockWorld) +runSysfsGpioMock' a w c = either (Left . fromException) return $ runSysfsGpioMock a w c + +evalSysfsMock' :: SysfsMock a -> MockWorld -> [MockGpioChip] -> Either (Maybe SysfsException) a +evalSysfsMock' a w c = either (Left . fromException) Right $ evalSysfsMock a w c + +spec :: Spec +spec = + do describe "pins" $ + let pinList = map Pin [0..15] + expectedResult = Right pinList + in + it "returns the list of available pins" $ + evalSysfsGpioMock' pins initialMockWorld [chip0] `shouldBe` expectedResult + + describe "pinCapabilities" $ + do it "returns a pin's capabilities" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState + ,defaultMockPinState {_userVisibleDirection = False} + ,defaultMockPinState {_edge = Nothing}] + (Right result) = + evalSysfsGpioMock' + (do c1 <- pinCapabilities (Pin 1) + c2 <- pinCapabilities (Pin 2) + c3 <- pinCapabilities (Pin 3) + return (c1,c2,c3) + ) + initialMockWorld + [testChip] + in do result + `shouldBe` + (PinCapabilities (Set.fromList [InputDefault]) (Set.fromList [OutputDefault]) True, + PinCapabilities Set.empty Set.empty False, + PinCapabilities (Set.fromList [InputDefault]) (Set.fromList [OutputDefault]) False) + it "doesn't leave any pin state around" $ + let (Right world) = + execSysfsGpioMock (void $ pinCapabilities (Pin 1)) initialMockWorld [chip0] + in evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + it "fails if the pin doesn't exist" $ + let (Left failure) = + evalSysfsGpioMock' (pinCapabilities (Pin 99)) initialMockWorld [chip0] + in failure `shouldBe` (Just $ InvalidPin (Pin 99)) + + describe "openPin/closePin" $ + do it "cleans up properly" $ + let (Right world) = execSysfsGpioMock' testOpenClose initialMockWorld [chip0] + in evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + it "fails when the pin is unavailable" $ + evalSysfsGpioMock' testOpenClose initialMockWorld [chip1] `shouldBe` Left (Just $ InvalidPin (Pin 1)) + it "openPin does not error when the pin is already open" $ + evalSysfsGpioMock' (openPin (Pin 1) >> openPin (Pin 1) >> return ()) initialMockWorld [chip0] `shouldBe` Right () + + it "closePin does not error when the pin is already closed" $ + evalSysfsGpioMock' (do { h <- openPin (Pin 1) ; closePin h ; closePin h} ) initialMockWorld [chip0] `shouldBe` Right () + + describe "getPinDirection" $ + do it "gets the pin's direction" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In}] + in + do evalSysfsGpioMock' (withPin (Pin 1) getPinDirection) initialMockWorld [chip0] `shouldBe` Right Out + evalSysfsGpioMock' (withPin (Pin 1) getPinDirection) initialMockWorld [testChip] `shouldBe` Right In + + it "fails when the pin direction is not settable" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_userVisibleDirection = False}] + in evalSysfsGpioMock' (withPin (Pin 1) getPinDirection) initialMockWorld [testChip] `shouldBe` Left (Just $ NoDirectionAttribute (Pin 1)) + + describe "getPinInputMode" $ + do it "gets the pin's input mode" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In}] + in + evalSysfsGpioMock' (withPin (Pin 1) getPinInputMode) initialMockWorld [testChip] `shouldBe` Right InputDefault + it "fails when the pin's direction is Out" $ + evalSysfsGpioMock' (withPin (Pin 1) getPinInputMode) initialMockWorld [chip0] `shouldBe` Left (Just $ InvalidOperation (Pin 1)) + + describe "setPinInputMode" $ + do it "sets the pin's input mode and direction" $ + let testChip1 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = Out, _edge = Just Falling, _activeLow = True}] + testChip2 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _edge = Just Rising}] + (Right (result1,world1)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinInputMode h InputDefault >> getPinInputMode h) initialMockWorld [testChip1] + (Right (result2,world2)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinInputMode h InputDefault >> getPinInputMode h) initialMockWorld [testChip2] + in do result1 `shouldBe` InputDefault + result2 `shouldBe` InputDefault + Map.lookup (Pin 1) (mockWorldPins world1) `shouldBe` Just (defaultMockPinState {_direction = In, _edge = Just Falling, _activeLow = True}) + Map.lookup (Pin 1) (mockWorldPins world2) `shouldBe` Just (defaultMockPinState {_direction = In, _edge = Just Rising}) + + it "fails when the input mode is unsupported" $ + evalSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinInputMode h InputFloating) initialMockWorld [chip0] `shouldBe` Left (Just $ (UnsupportedInputMode InputFloating (Pin 1))) + it "fails when the pin's direction is not settable" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_userVisibleDirection = False}] + in evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinInputMode h InputDefault)) initialMockWorld [testChip] `shouldBe` Left (Just $ NoDirectionAttribute (Pin 1)) + + describe "getPinOutputMode" $ + do it "gets the pin's output mode" $ + evalSysfsGpioMock' (withPin (Pin 1) getPinOutputMode) initialMockWorld [chip0] `shouldBe` Right OutputDefault + it "fails when the pin's direction is Out" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In}] + in evalSysfsGpioMock' (withPin (Pin 1) getPinOutputMode) initialMockWorld [testChip] `shouldBe` Left (Just $ InvalidOperation (Pin 1)) + + describe "setPinOutputMode" $ + do it "sets the pin's output mode, value, and direction" $ + let testChip1 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _value = Low}] + (Right (result1,world1)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault High >> getPinOutputMode h) initialMockWorld [testChip1] + testChip2 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _value = Low}] + (Right (result2,world2)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault Low >> getPinOutputMode h) initialMockWorld [testChip2] + testChip3 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = Out, _value = High}] + (Right (result3,world3)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault Low >> getPinOutputMode h) initialMockWorld [testChip3] + (Right (result4,world4)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault High >> getPinOutputMode h) initialMockWorld [chip0] + in do result1 `shouldBe` OutputDefault + result2 `shouldBe` OutputDefault + result3 `shouldBe` OutputDefault + result4 `shouldBe` OutputDefault + Map.lookup (Pin 1) (mockWorldPins world1) `shouldBe` Just (defaultMockPinState {_direction = Out, _value = High}) + Map.lookup (Pin 1) (mockWorldPins world2) `shouldBe` Just (defaultMockPinState {_direction = Out, _value = Low}) + Map.lookup (Pin 1) (mockWorldPins world3) `shouldBe` Just (defaultMockPinState {_direction = Out, _value = Low}) + Map.lookup (Pin 1) (mockWorldPins world4) `shouldBe` Just (defaultMockPinState {_direction = Out, _value = High}) + it "respects the pin's active level" $ + let testChip1 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _value = Low, _activeLow = True}] + (Right (result1,world1)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault High >> getPinOutputMode h) initialMockWorld [testChip1] + testChip2 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _value = Low, _activeLow = True}] + (Right (result2,world2)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault Low >> getPinOutputMode h) initialMockWorld [testChip2] + testChip3 = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = Out, _value = High, _activeLow = True}] + (Right (result3,world3)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault Low >> getPinOutputMode h) initialMockWorld [testChip3] + testChip4 = MockGpioChip "testChip" 1 [defaultMockPinState {_activeLow = True}] + (Right (result4,world4)) = runSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputDefault High >> getPinOutputMode h) initialMockWorld [testChip4] + in do result1 `shouldBe` OutputDefault + result2 `shouldBe` OutputDefault + result3 `shouldBe` OutputDefault + result4 `shouldBe` OutputDefault + Map.lookup (Pin 1) (mockWorldPins world1) `shouldBe` Just (defaultMockPinState {_direction = Out, _activeLow = True, _value = Low}) + Map.lookup (Pin 1) (mockWorldPins world2) `shouldBe` Just (defaultMockPinState {_direction = Out, _activeLow = True, _value = High}) + Map.lookup (Pin 1) (mockWorldPins world3) `shouldBe` Just (defaultMockPinState {_direction = Out, _activeLow = True, _value = High}) + Map.lookup (Pin 1) (mockWorldPins world4) `shouldBe` Just (defaultMockPinState {_direction = Out, _activeLow = True, _value = Low}) + it "fails when the output mode is unsupported" $ + evalSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinOutputMode h OutputPushPull Low) initialMockWorld [chip0] `shouldBe` Left (Just $ (UnsupportedOutputMode OutputPushPull (Pin 1))) + it "can change the pin direction to 'Out' when the pin is configured for edge- or level-triggered reads " $ + evalSysfsGpioMock' + (withPin (Pin 1) $ \h -> + do setPinInputMode h InputDefault + setPinInterruptMode h RisingEdge + setPinOutputMode h OutputDefault Low + setPinInputMode h InputDefault + setPinInterruptMode h FallingEdge + setPinOutputMode h OutputDefault Low + setPinInputMode h InputDefault + setPinInterruptMode h Level + setPinOutputMode h OutputDefault Low + return True) + initialMockWorld + [chip0] + `shouldBe` Right True + it "fails when the pin's direction is not settable" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_userVisibleDirection = False}] + in evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinOutputMode h OutputDefault Low)) initialMockWorld [testChip] `shouldBe` Left (Just $ NoDirectionAttribute (Pin 1)) + + describe "getPinInterruptMode" $ + do it "gets the pin's interrupt mode" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_edge = Just Falling}] + in + do evalSysfsGpioMock' (withPin (Pin 1) getPinInterruptMode) initialMockWorld [chip0] `shouldBe` Right Disabled + evalSysfsGpioMock' (withPin (Pin 1) getPinInterruptMode) initialMockWorld [testChip] `shouldBe` Right FallingEdge + + it "fails when the pin's interrupt mode is not settable" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_edge = Nothing}] + in evalSysfsGpioMock' (withPin (Pin 1) getPinInterruptMode) initialMockWorld [testChip] `shouldBe` Left (Just $ NoEdgeAttribute (Pin 1)) + + describe "setPinInterruptMode" $ + do it "sets the pin's interrupt mode" $ + evalSysfsGpioMock' testSetInterruptMode initialMockWorld [chip0] `shouldBe` Right (Disabled, RisingEdge, FallingEdge, Level) + it "is idempotent" $ + evalSysfsGpioMock' testSetInterruptModeIdempotent initialMockWorld [chip0] `shouldBe` Right (FallingEdge, FallingEdge) + it "fails when the pin's interrupt mode is not settable" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_edge = Nothing}, defaultMockPinState] + in evalSysfsGpioMock' testSetInterruptMode initialMockWorld [testChip] `shouldBe` Left (Just $ NoEdgeAttribute (Pin 1)) + it "fails when the pin is configured for output" $ + evalSysfsGpioMock' (withPin (Pin 1) $ \h -> setPinInterruptMode h Level) initialMockWorld [chip0] `shouldBe` Left (Just $ InvalidOperation (Pin 1)) + + describe "getPinActiveLevel" $ + do context "when active level is high" $ + do it "returns the pin's active level" $ + evalSysfsGpioMock' (withPin (Pin 1) getPinActiveLevel) initialMockWorld [chip0] `shouldBe` Right ActiveHigh + context "when active level is low" $ + do it "returns the pin's active level" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_activeLow = True}] + in evalSysfsGpioMock' (withPin (Pin 1) getPinActiveLevel) initialMockWorld [testChip] `shouldBe` Right ActiveLow + + describe "setPinActiveLevel" $ + do context "when active level is high" $ + do it "sets the pin's active level to low" $ + let (Right (result, world)) = runSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveLow >> getPinActiveLevel h)) initialMockWorld [chip0] + in do result `shouldBe` ActiveLow + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just (defaultMockPinState {_activeLow = True}) + it "sets the pin's active level to high" $ + let (Right (result, world)) = runSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveHigh >> getPinActiveLevel h)) initialMockWorld [chip0] + in do result `shouldBe` ActiveHigh + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just (defaultMockPinState {_activeLow = False}) + context "when active level is low" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_activeLow = True}] + in do it "sets the pin's active level to low" $ + let (Right (result, world)) = runSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveLow >> getPinActiveLevel h)) initialMockWorld [testChip] + in do result `shouldBe` ActiveLow + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just (defaultMockPinState {_activeLow = True}) + it "sets the pin's active level to high" $ + let (Right (result, world)) = runSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveHigh >> getPinActiveLevel h)) initialMockWorld [chip0] + in do result `shouldBe` ActiveHigh + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just (defaultMockPinState {_activeLow = False}) + + describe "togglePinActiveLevel" $ + do it "toggles the pin's active level when the pin is configured for output" $ + evalSysfsGpioMock' (withPin (Pin 1) testTogglePinActiveLevel) initialMockWorld [chip0] `shouldBe` Right (ActiveHigh, ActiveLow, ActiveLow, ActiveHigh, ActiveHigh) + it "and when the pin is configured for input" $ + evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinInputMode h InputDefault >> testTogglePinActiveLevel h)) initialMockWorld [chip0] `shouldBe` Right (ActiveHigh, ActiveLow, ActiveLow, ActiveHigh, ActiveHigh) + + describe "pollPin" $ + do it "waits for the specified trigger and returns the pin's value" $ + pendingWith "need to implement this" + + it "blocks when the interrupt mode is Disabled, until it is changed" $ + pendingWith "need to implement this" + + describe "pollPinTimeout" $ + do it "waits for the specified trigger and returns the pin's value" $ + pendingWith "need to implement this" + it "blocks when the interrupt mode is Disabled, until it is changed" $ + pendingWith "need to implement this" + it "times out" $ + pendingWith "need to implement this" + + describe "readPin" $ + do context "returns the pin's logical level" $ + do it "when the active level is high" $ + evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveHigh >> readPin h)) initialMockWorld [chip0] `shouldBe` Right Low + it "when the active level is low" $ + evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveLow >> readPin h)) initialMockWorld [chip0] `shouldBe` Right High + + describe "writePin" $ + do context "sets the pin's logical value" $ + do it "when the active level is high" $ + let Right (result, world) = runSysfsGpioMock' (withPin (Pin 1) testReadWritePin) initialMockWorld [chip0] + in do result `shouldBe` (Low, High, Low) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState + it "when the active level is low" $ + let Right (result, world) = runSysfsGpioMock' (withPin (Pin 1) (\h -> setPinActiveLevel h ActiveLow >> testReadWritePin h)) initialMockWorld [chip0] + in do result `shouldBe` (High, Low, High) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just (defaultMockPinState {_activeLow = True, _value = Low}) + + it "is idempotent" $ + evalSysfsGpioMock' testReadWritePinIdempotent initialMockWorld [chip0] `shouldBe` Right (Low, Low) + + it "fails when the pin direction is In" $ + evalSysfsGpioMock' testWritePinFailsOnInputPin initialMockWorld [chip0] `shouldBe` Left (Just $ PermissionDenied (Pin 1)) + + describe "togglePin" $ + do it "toggles the pin's value" $ + evalSysfsGpioMock' testTogglePinValue initialMockWorld [chip0] `shouldBe` Right (Low, High, High, Low, Low) + it "fails when the pin is not configured for output" $ + evalSysfsGpioMock' (withPin (Pin 1) (\h -> setPinInputMode h InputDefault >> togglePin h)) initialMockWorld [chip0] `shouldBe` Left (Just $ PermissionDenied (Pin 1)) + + describe "operations on an invalid handle fail" $ + -- Note: When used on an invalid handle, GPIO commands which + -- return a 'Maybe' result will fail differently than commands + -- which do not. This is by design. + do it "in getPinDirection" $ + evalSysfsGpioMock' (invalidHandle getPinDirection) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in getPinInputMode" $ + evalSysfsGpioMock' (invalidHandle getPinInputMode) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in setPinInputMode" $ + evalSysfsGpioMock' (invalidHandle (\d -> setPinInputMode d InputDefault)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in getPinOutputMode" $ + evalSysfsGpioMock' (invalidHandle getPinOutputMode) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in setPinOutputMode" $ + evalSysfsGpioMock' (invalidHandle (\h -> setPinOutputMode h OutputDefault Low)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in readPin" $ + evalSysfsGpioMock' (invalidHandle readPin) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in pollPin" $ + evalSysfsGpioMock' (invalidHandle pollPin) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in pollPinTimeout" $ + evalSysfsGpioMock' (invalidHandle (\h -> pollPinTimeout h 10000)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in writePin" $ + evalSysfsGpioMock' (invalidHandle (\d -> writePin d High)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in togglePin" $ + evalSysfsGpioMock' (invalidHandle togglePin) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in getPinInterruptMode" $ + evalSysfsGpioMock' (invalidHandle getPinInterruptMode) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in setPinInterruptMode" $ + evalSysfsGpioMock' (invalidHandle (\d -> setPinInterruptMode d Level)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in getPinActiveLevel" $ + evalSysfsGpioMock' (invalidHandle getPinActiveLevel) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in setPinActiveLevel" $ + evalSysfsGpioMock' (invalidHandle (\d -> setPinActiveLevel d ActiveHigh)) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + it "in togglePinActiveLevel" $ + evalSysfsGpioMock' (invalidHandle togglePinActiveLevel) initialMockWorld [chip0] `shouldBe` Left (Just $ NotExported (Pin 1)) + + describe "withPin" $ + do it "opens and closes the pin as expected" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_value = High}] + (Right world) = execSysfsGpioMock' testWithPin initialMockWorld [testChip] + in evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + + it "throws an exception when the pin doesn't exist" $ + evalSysfsGpioMock' testWithPin initialMockWorld [chip1] `shouldBe` Left (Just $ InvalidPin (Pin 1)) + + it "can nest" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_value = High}, defaultMockPinState] + (Right (result, world)) = runSysfsGpioMock' (testNestedWithPin (Pin 1) (Pin 2)) initialMockWorld [testChip] + in do result `shouldBe` (High, Low) + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio2") world [] `shouldBe` Right False + + it "handles double-open and double-close without complaint" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_value = High}, defaultMockPinState] + (Right (result, world)) = runSysfsGpioMock' (testNestedWithPin (Pin 1) (Pin 1)) initialMockWorld [testChip] + in do result `shouldBe` (Low, Low) + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + + it "cleans up when an exception occurs in the computation" $ + let (Right (result, world)) = runSysfsGpioMock' (testWithPinError (Pin 1) (Pin 2)) initialMockWorld [chip0] + in do result `shouldBe` Nothing + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio2") world [] `shouldBe` Right False + + describe "InputPin" $ + do context "withInputPin" $ + do it "opens and configures a pin for input, then closes closes it" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In}, defaultMockPinState {_direction = Out}] + (Right world) = + execSysfsGpioMock' + (withInputPin (Pin 1) InputDefault Nothing $ \_ -> + withInputPin (Pin 2) InputDefault Nothing $ \_ -> + return () + ) + initialMockWorld + [testChip] + in do evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio2") world [] `shouldBe` Right False + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In} + it "sets the pin's input mode" $ + evalSysfsGpioMock' + (withInputPin (Pin 1) InputDefault Nothing $ \h -> + getInputPinInputMode h + ) + initialMockWorld + [chip0] + `shouldBe` Right InputDefault + it "sets (or doesn't) the pin's active level" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_activeLow = True}, defaultMockPinState {_activeLow = True}] + (Right world) = + execSysfsGpioMock' + (withInputPin (Pin 1) InputDefault Nothing $ \_ -> + withInputPin (Pin 2) InputDefault (Just ActiveHigh) $ \_ -> + return () + ) + initialMockWorld + [testChip] + in do Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} + it "fails if the pin's direction is fixed" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState, defaultMockPinState {_direction = Out, _userVisibleDirection = False}] + in evalSysfsGpioMock' + (withInputPin (Pin 1) InputDefault Nothing $ \_ -> + withInputPin (Pin 2) InputDefault (Just ActiveHigh) $ \_ -> + return () + ) + initialMockWorld + [testChip] + `shouldBe` + Left (Just $ NoDirectionAttribute (Pin 2)) + context "readInputPin" $ + do it "respects the pin's active level" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_value = High}, defaultMockPinState {_value = Low}] + in evalSysfsGpioMock' + (withInputPin (Pin 1) InputDefault Nothing $ \h1 -> + withInputPin (Pin 2) InputDefault (Just ActiveLow) $ \h2 -> + do v1 <- readInputPin h1 + v2 <- readInputPin h2 + return (v1,v2) + ) + initialMockWorld + [testChip] + `shouldBe` + Right (High,High) + context "getInputPinInputMode" $ + do it "gets the pin's input mode" $ + evalSysfsGpioMock' + (withInputPin (Pin 1) InputDefault Nothing $ \h -> + getInputPinInputMode h + ) + initialMockWorld + [chip0] + `shouldBe` Right InputDefault + context "get/setInputPinActiveLevel" $ + do it "gets/sets the pin's active level" $ + let (Right (result, world)) = + runSysfsGpioMock' + (withInputPin (Pin 1) InputDefault (Just ActiveHigh) $ \h1 -> + withInputPin (Pin 2) InputDefault (Just ActiveLow) $ \h2 -> + do setInputPinActiveLevel h1 ActiveLow + setInputPinActiveLevel h2 ActiveHigh + l1 <- getInputPinActiveLevel h1 + l2 <- getInputPinActiveLevel h2 + return (l1,l2) + ) + initialMockWorld + [chip0] + in do result `shouldBe` (ActiveLow,ActiveHigh) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} + context "toggleInputPinActiveLevel" $ + do it "toggles the pin's active level and returns the new value" $ + let (Right (result, world)) = + runSysfsGpioMock' + (withInputPin (Pin 1) InputDefault (Just ActiveHigh) $ \h1 -> + withInputPin (Pin 2) InputDefault (Just ActiveLow) $ \h2 -> + do l1 <- toggleInputPinActiveLevel h1 + l2 <- toggleInputPinActiveLevel h2 + return (l1,l2) + ) + initialMockWorld + [chip0] + in do result `shouldBe` (ActiveLow,ActiveHigh) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} + describe "InterruptPin" $ + do context "withInterruptPin" $ + do it "opens and configures a pin for interrupts, sets its interrupt mode, then closes closes it" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In, _edge = Just None}, defaultMockPinState {_direction = Out, _edge = Just Rising}] + (Right world) = + execSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault FallingEdge Nothing $ \_ -> + withInterruptPin (Pin 2) InputDefault Disabled Nothing $ \_ -> + return () + ) + initialMockWorld + [testChip] + in do evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio2") world [] `shouldBe` Right False + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _edge = Just Falling} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _edge = Just None} + it "sets (or doesn't) the pin's active level" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_activeLow = True}, defaultMockPinState {_activeLow = True}] + (Right world) = + execSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \_ -> + withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveHigh) $ \_ -> + return () + ) + initialMockWorld + [testChip] + in do Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} + it "fails if the pin's direction is fixed" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState, defaultMockPinState {_direction = Out, _userVisibleDirection = False}] + in evalSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \_ -> + withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveHigh) $ \_ -> + return () + ) + initialMockWorld + [testChip] + `shouldBe` + Left (Just $ NoDirectionAttribute (Pin 2)) + it "fails if the pin doesn't support interrupts" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState, defaultMockPinState {_edge = Nothing}] + in evalSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \_ -> + withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveHigh) $ \_ -> + return () + ) + initialMockWorld + [testChip] + `shouldBe` + Left (Just $ NoEdgeAttribute (Pin 2)) + context "readInterruptPin" $ + do it "respects the pin's active level" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_value = High}, defaultMockPinState {_value = Low}] + in evalSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \h1 -> + withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveLow) $ \h2 -> + do v1 <- readInterruptPin h1 + v2 <- readInterruptPin h2 + return (v1,v2) + ) + initialMockWorld + [testChip] + `shouldBe` + Right (High,High) + context "getInterruptPinInputMode" $ + do it "gets the pin's input mode" $ + evalSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \h -> + getInterruptPinInputMode h + ) + initialMockWorld + [chip0] + `shouldBe` Right InputDefault + context "get/setInterruptPinActiveLevel" $ + do it "gets/sets the pin's active level" $ + let (Right (result, world)) = + runSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault Disabled (Just ActiveHigh) $ \h1 -> + withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveLow) $ \h2 -> + do setInterruptPinActiveLevel h1 ActiveLow + setInterruptPinActiveLevel h2 ActiveHigh + l1 <- getInterruptPinActiveLevel h1 + l2 <- getInterruptPinActiveLevel h2 + return (l1,l2) + ) + initialMockWorld + [chip0] + in do result `shouldBe` (ActiveLow,ActiveHigh) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} + context "toggleInterruptPinActiveLevel" $ + do it "toggles the pin's active level and returns the new value" $ + let (Right (result, world)) = + runSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault Disabled (Just ActiveHigh) $ \h1 -> + withInterruptPin (Pin 2) InputDefault Disabled (Just ActiveLow) $ \h2 -> + do l1 <- toggleInterruptPinActiveLevel h1 + l2 <- toggleInterruptPinActiveLevel h2 + return (l1,l2) + ) + initialMockWorld + [chip0] + in do result `shouldBe` (ActiveLow,ActiveHigh) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = True} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _activeLow = False} + context "get/setInterruptPinInterruptMode" $ + do it "gets/sets the pin's interrupt mode" $ + let (Right (result, world)) = + runSysfsGpioMock' + (withInterruptPin (Pin 1) InputDefault Disabled Nothing $ \h1 -> + withInterruptPin (Pin 2) InputDefault RisingEdge Nothing $ \h2 -> + do setInterruptPinInterruptMode h1 RisingEdge + setInterruptPinInterruptMode h2 Disabled + m1 <- getInterruptPinInterruptMode h1 + m2 <- getInterruptPinInterruptMode h2 + return (m1,m2) + ) + initialMockWorld + [chip0] + in do result `shouldBe` (RisingEdge,Disabled) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _edge = Just Rising} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = In, _edge = Just None} + context "pollInterruptPin" $ + do it "waits for interrupts" $ + pendingWith "need to implement this" + it "respects the pin's active level" $ + pendingWith "need to implement this" + + context "pollInterruptPin" $ + do it "waits for interrupts" $ + pendingWith "need to implement this" + it "times out" $ + pendingWith "need to implement this" + it "respects the pin's active level" $ + pendingWith "need to implement this" + describe "OutputPin" $ + do context "withOutputPin" $ + do it "opens and configures a pin for output, sets its value, then closes closes it" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState {_direction = In}, defaultMockPinState {_direction = Out, _value = High}] + (Right world) = + execSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault Nothing High $ \_ -> + withOutputPin (Pin 2) OutputDefault Nothing Low $ \_ -> + return () + ) + initialMockWorld + [testChip] + in do evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio1") world [] `shouldBe` Right False + evalSysfsMock' (doesDirectoryExist "/sys/class/gpio/gpio2") world [] `shouldBe` Right False + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = High} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = Low} + it "sets (or doesn't) the pin's active level (and the output value is relative to it)" $ + let (Right world) = + execSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault Nothing Low $ \_ -> + withOutputPin (Pin 2) OutputDefault Nothing High $ \_ -> + withOutputPin (Pin 3) OutputDefault (Just ActiveLow) Low $ \_ -> + withOutputPin (Pin 4) OutputDefault (Just ActiveLow) High $ \_ -> + withOutputPin (Pin 5) OutputDefault (Just ActiveHigh) Low $ \_ -> + withOutputPin (Pin 6) OutputDefault (Just ActiveHigh) High $ \_ -> + return () + ) + initialMockWorld + [chip0] + in do Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = High} + Map.lookup (Pin 3) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = High} + Map.lookup (Pin 4) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = Low} + Map.lookup (Pin 5) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = Low} + Map.lookup (Pin 6) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = High} + it "fails if the pin's direction is fixed" $ + let testChip = MockGpioChip "testChip" 1 [defaultMockPinState, defaultMockPinState {_direction = Out, _userVisibleDirection = False}] + in evalSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault Nothing High $ \_ -> + withOutputPin (Pin 2) OutputDefault Nothing Low $ \_ -> + return () + ) + initialMockWorld + [testChip] + `shouldBe` + Left (Just $ NoDirectionAttribute (Pin 2)) + context "readOutputPin" $ + do it "respects the pin's active level" $ + evalSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault Nothing Low $ \h1 -> + withOutputPin (Pin 2) OutputDefault (Just ActiveLow) High $ \h2 -> + do v1 <- readOutputPin h1 + v2 <- readOutputPin h2 + return (v1,v2) + ) + initialMockWorld + [chip0] + `shouldBe` + Right (Low,High) + context "writeOutputPin" $ + do it "writes the output value and respects the pin's active level" $ + let (Right world) = + execSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault (Just ActiveLow) High $ \h1 -> + withOutputPin (Pin 2) OutputDefault (Just ActiveLow) Low $ \h2 -> + withOutputPin (Pin 3) OutputDefault (Just ActiveHigh) High $ \h3 -> + withOutputPin (Pin 4) OutputDefault (Just ActiveHigh) Low $ \h4 -> + do writeOutputPin h1 Low + writeOutputPin h2 High + writeOutputPin h3 Low + writeOutputPin h4 High + ) + initialMockWorld + [chip0] + in do Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = High} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = Low} + Map.lookup (Pin 3) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = Low} + Map.lookup (Pin 4) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = High} + context "toggleOutputPin" $ + do it "toggles the output value, returns the new value, and respects the pin's active level" $ + let (Right (result, world)) = + runSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault (Just ActiveLow) High $ \h1 -> + withOutputPin (Pin 2) OutputDefault (Just ActiveLow) Low $ \h2 -> + withOutputPin (Pin 3) OutputDefault (Just ActiveHigh) High $ \h3 -> + withOutputPin (Pin 4) OutputDefault (Just ActiveHigh) Low $ \h4 -> + do v1 <- toggleOutputPin h1 + v2 <- toggleOutputPin h2 + v3 <- toggleOutputPin h3 + v4 <- toggleOutputPin h4 + return (v1,v2,v3,v4) + ) + initialMockWorld + [chip0] + in do result `shouldBe` (Low,High,Low,High) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = High} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True, _value = Low} + Map.lookup (Pin 3) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = Low} + Map.lookup (Pin 4) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _value = High} + context "getOutputPinOutputMode" $ + do it "gets the pin's input mode" $ + evalSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault Nothing Low $ \h -> + getOutputPinOutputMode h + ) + initialMockWorld + [chip0] + `shouldBe` Right OutputDefault + context "get/setOutputPinActiveLevel" $ + do it "gets/sets the pin's active level" $ + let (Right (result, world)) = + runSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault (Just ActiveHigh) Low $ \h1 -> + withOutputPin (Pin 2) OutputDefault (Just ActiveLow) Low $ \h2 -> + do setOutputPinActiveLevel h1 ActiveLow + setOutputPinActiveLevel h2 ActiveHigh + l1 <- getOutputPinActiveLevel h1 + l2 <- getOutputPinActiveLevel h2 + return (l1,l2) + ) + initialMockWorld + [chip0] + in do result `shouldBe` (ActiveLow,ActiveHigh) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = False, _value = High} + context "toggleOutputPinActiveLevel" $ + do it "toggles the pin's active level and returns the new value" $ + let (Right (result, world)) = + runSysfsGpioMock' + (withOutputPin (Pin 1) OutputDefault (Just ActiveHigh) Low $ \h1 -> + withOutputPin (Pin 2) OutputDefault (Just ActiveLow) Low $ \h2 -> + do l1 <- toggleOutputPinActiveLevel h1 + l2 <- toggleOutputPinActiveLevel h2 + return (l1,l2) + ) + initialMockWorld + [chip0] + in do result `shouldBe` (ActiveLow,ActiveHigh) + Map.lookup (Pin 1) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = True} + Map.lookup (Pin 2) (mockWorldPins world) `shouldBe` Just defaultMockPinState {_direction = Out, _activeLow = False, _value = High} diff --git a/test/Test/System/GPIO/TypesSpec.hs b/test/Test/System/GPIO/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/System/GPIO/TypesSpec.hs @@ -0,0 +1,144 @@ +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +#ifndef MIN_VERSION_base +#define MIN_VERSION_base(x,y,z) 1 +#endif + +module Test.System.GPIO.TypesSpec (spec) where + +import Protolude +import System.GPIO.Types + +import Data.Bits (unsafeShiftL, unsafeShiftR) +import Test.Hspec +import Test.QuickCheck (property) + +-- Test all our hand-derived instances and functions. + +-- PinValue mimics Bool with respect to Bits and FiniteBits. +-- +ib2v :: (Int -> Bool) -> Int -> PinValue +ib2v f n = boolToValue $ f n + +bi2v :: (Bool -> Int) -> PinValue -> Int +bi2v f a = f (valueToBool a) + +bb2v :: (Bool -> Bool) -> PinValue -> PinValue +bb2v f a = boolToValue $ f (valueToBool a) + +bbb2v :: (Bool -> Bool -> Bool) -> PinValue -> PinValue -> PinValue +bbb2v f a b = boolToValue $ f (valueToBool a) (valueToBool b) + +bib2v :: (Bool -> Int -> Bool) -> PinValue -> Int -> PinValue +bib2v f a n = boolToValue $ f (valueToBool a) n + +#if MIN_VERSION_base(4,8,0) +newBase :: Spec +newBase = + do context "implements the new base-4.8.0.0 FiniteBits typeclass methods" $ + do it "countLeadingZeros" $ property $ + \a -> countLeadingZeros a == bi2v countLeadingZeros a + it "countTrailingZeros" $ property $ + \a -> countTrailingZeros a == bi2v countTrailingZeros a +#else +newBase :: Spec +newBase = return () +#endif + +spec :: Spec +spec = + do describe "Pin" $ + do it "pinNumber" $ property $ + \p@(Pin n) -> n == pinNumber p + + describe "PinDirection" $ + do it "invertDirection" $ + invertDirection In == Out + && invertDirection Out == In + + describe "PinValue" $ + do it "invertValue" $ property $ + \a -> invertValue a == complement a + + it "valueToBool" $ + valueToBool Low == False + && valueToBool High == True + + it "boolToValue" $ + boolToValue False == Low + && boolToValue True == High + + context "implements the Bits typeclass" $ + do it "(.&.)" $ property $ + \a b -> a .&. b == bbb2v (.&.) a b + + it "(.|.)" $ property $ + \a b -> a .|. b == bbb2v (.|.) a b + + it "xor" $ property $ + \a b -> a `xor` b == bbb2v xor a b + + it "complement" $ property $ + \a -> complement a == bb2v complement a + + it "shift" $ property $ + \a n -> a `shift` n == bib2v shift a n + + it "rotate" $ property $ + \a n -> a `rotate` n == bib2v rotate a n + + it "zeroBits" $ property $ + (zeroBits :: PinValue) == boolToValue (zeroBits:: Bool) + + it "bit" $ property $ + \n -> bit n == ib2v bit n + + it "setBit" $ property $ + \a n -> a `setBit` n == bib2v setBit a n + + it "clearBit" $ property $ + \a n -> a `clearBit` n == bib2v clearBit a n + + it "complementBit" $ property $ + \a n -> a `complementBit` n == bib2v complementBit a n + + it "testBit" $ property $ + \a n -> testBit a n == testBit (valueToBool a) n + + it "bitSizeMaybe" $ property $ + \a -> bitSizeMaybe a == bitSizeMaybe (valueToBool a) + + it "bitSize" $ property $ + \a -> bitSize a == bitSize (valueToBool a) + + it "isSigned" $ property $ + \a -> isSigned a == isSigned (valueToBool a) + + it "shiftL" $ property $ + \a n -> a `shiftL` n == bib2v shiftL a n + + it "unsafeShiftL" $ property $ + \a n -> a `unsafeShiftL` n == bib2v unsafeShiftL a n + + it "shiftR" $ property $ + \a n -> a `shiftR` n == bib2v shiftR a n + + it "unsafeShiftR" $ property $ + \a n -> a `unsafeShiftR` n == bib2v unsafeShiftR a n + + it "rotateL" $ property $ + \a n -> a `rotateL` n == bib2v rotateL a n + + it "rotateR" $ property $ + \a n -> a `rotateR` n == bib2v rotateR a n + + it "popCount" $ property $ + \a -> popCount a == popCount (valueToBool a) + + context "implements the FiniteBits typeclass" $ + do it "finiteBitSize" $ property $ + \a -> finiteBitSize a == bi2v finiteBitSize a + + newBase diff --git a/test/doctest.hs b/test/doctest.hs --- a/test/doctest.hs +++ b/test/doctest.hs @@ -1,6 +1,6 @@ module Main where -import Data.Monoid ((<>)) +import Protolude import System.FilePath (()) import Test.DocTest @@ -10,15 +10,12 @@ testFiles :: [FilePath] testFiles = map addPrefix - [ "Monad.hs" - , "Tutorial.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) +main = doctest (["-isrc", "-XNoImplicitPrelude"] <> testFiles) diff --git a/test/hlint.hs b/test/hlint.hs --- a/test/hlint.hs +++ b/test/hlint.hs @@ -1,9 +1,7 @@ module Main where -import Control.Monad (unless) +import Protolude import Language.Haskell.HLint -import System.Environment -import System.Exit main :: IO () main =