hpio 0.8.0.10 → 0.9.0.0
raw patch · 36 files changed
+3562/−3624 lines, 36 filesdep +faildep +monad-controldep +monad-loggerdep −base-compatdep −mtl-compatdep −transformers-compatdep ~asyncdep ~bytestringdep ~exceptionsPVP ok
version bump matches the API change (PVP)
Dependencies added: fail, monad-control, monad-logger, protolude, semigroups, transformers-base
Dependencies removed: base-compat, mtl-compat, transformers-compat
Dependency ranges changed: async, bytestring, exceptions, mtl, optparse-applicative, text, transformers, unix, unix-bytestring
API changes (from Hackage documentation)
- System.GPIO.Linux.Sysfs.Mock: instance (GHC.Base.Functor m, Control.Monad.Catch.MonadThrow m) => System.GPIO.Linux.Sysfs.Monad.MonadSysfs (System.GPIO.Linux.Sysfs.Mock.SysfsMockT m)
- System.GPIO.Linux.Sysfs.Monad: instance (GHC.Base.Functor m, Control.Monad.Catch.MonadCatch m, Control.Monad.Catch.MonadMask m, Control.Monad.Catch.MonadThrow m, System.GPIO.Linux.Sysfs.Monad.MonadSysfs m) => System.GPIO.Monad.MonadGpio System.GPIO.Linux.Sysfs.Monad.PinDescriptor (System.GPIO.Linux.Sysfs.Monad.SysfsGpioT m)
+ System.GPIO.Linux.Sysfs.IO: instance Control.Monad.Base.MonadBase b m => Control.Monad.Base.MonadBase b (System.GPIO.Linux.Sysfs.IO.SysfsIOT m)
+ System.GPIO.Linux.Sysfs.IO: instance Control.Monad.Logger.MonadLogger m => Control.Monad.Logger.MonadLogger (System.GPIO.Linux.Sysfs.IO.SysfsIOT m)
+ System.GPIO.Linux.Sysfs.IO: instance Control.Monad.Logger.MonadLoggerIO m => Control.Monad.Logger.MonadLoggerIO (System.GPIO.Linux.Sysfs.IO.SysfsIOT m)
+ System.GPIO.Linux.Sysfs.IO: instance Control.Monad.Trans.Control.MonadBaseControl b m => Control.Monad.Trans.Control.MonadBaseControl b (System.GPIO.Linux.Sysfs.IO.SysfsIOT m)
+ System.GPIO.Linux.Sysfs.IO: instance Control.Monad.Trans.Control.MonadTransControl System.GPIO.Linux.Sysfs.IO.SysfsIOT
+ System.GPIO.Linux.Sysfs.Mock: instance Control.Monad.Base.MonadBase b m => Control.Monad.Base.MonadBase b (System.GPIO.Linux.Sysfs.Mock.SysfsMockT m)
+ System.GPIO.Linux.Sysfs.Mock: instance Control.Monad.Logger.MonadLogger m => Control.Monad.Logger.MonadLogger (System.GPIO.Linux.Sysfs.Mock.SysfsMockT m)
+ System.GPIO.Linux.Sysfs.Mock: instance Control.Monad.Logger.MonadLoggerIO m => Control.Monad.Logger.MonadLoggerIO (System.GPIO.Linux.Sysfs.Mock.SysfsMockT m)
+ System.GPIO.Linux.Sysfs.Mock: instance Control.Monad.Trans.Control.MonadBaseControl b m => Control.Monad.Trans.Control.MonadBaseControl b (System.GPIO.Linux.Sysfs.Mock.SysfsMockT m)
+ System.GPIO.Linux.Sysfs.Mock: instance Control.Monad.Trans.Control.MonadTransControl System.GPIO.Linux.Sysfs.Mock.SysfsMockT
+ System.GPIO.Linux.Sysfs.Mock: instance System.GPIO.Linux.Sysfs.Mock.MockM m => System.GPIO.Linux.Sysfs.Monad.MonadSysfs (System.GPIO.Linux.Sysfs.Mock.SysfsMockT m)
+ System.GPIO.Linux.Sysfs.Mock.Internal: ActiveLow :: Pin -> FileType
+ System.GPIO.Linux.Sysfs.Mock.Internal: Constant :: [ByteString] -> FileType
+ System.GPIO.Linux.Sysfs.Mock.Internal: DirNode :: !Name -> [File] -> DirNode
+ System.GPIO.Linux.Sysfs.Mock.Internal: Direction :: Pin -> FileType
+ System.GPIO.Linux.Sysfs.Mock.Internal: Edge :: Pin -> FileType
+ System.GPIO.Linux.Sysfs.Mock.Internal: Export :: FileType
+ System.GPIO.Linux.Sysfs.Mock.Internal: File :: !Name -> !FileType -> File
+ System.GPIO.Linux.Sysfs.Mock.Internal: MockFSCrumb :: DirNode -> [Directory] -> [Directory] -> MockFSCrumb
+ System.GPIO.Linux.Sysfs.Mock.Internal: MockFSZipper :: Directory -> [MockFSCrumb] -> MockFSZipper
+ System.GPIO.Linux.Sysfs.Mock.Internal: Unexport :: FileType
+ System.GPIO.Linux.Sysfs.Mock.Internal: Value :: Pin -> FileType
+ System.GPIO.Linux.Sysfs.Mock.Internal: [_crumbs] :: MockFSZipper -> [MockFSCrumb]
+ System.GPIO.Linux.Sysfs.Mock.Internal: [_cwd] :: MockFSZipper -> Directory
+ System.GPIO.Linux.Sysfs.Mock.Internal: [_dirNodeName] :: DirNode -> !Name
+ System.GPIO.Linux.Sysfs.Mock.Internal: [_fileName] :: File -> !Name
+ System.GPIO.Linux.Sysfs.Mock.Internal: [_fileType] :: File -> !FileType
+ System.GPIO.Linux.Sysfs.Mock.Internal: [_files] :: DirNode -> [File]
+ System.GPIO.Linux.Sysfs.Mock.Internal: [_node] :: MockFSCrumb -> DirNode
+ System.GPIO.Linux.Sysfs.Mock.Internal: [_pred] :: MockFSCrumb -> [Directory]
+ System.GPIO.Linux.Sysfs.Mock.Internal: [_succ] :: MockFSCrumb -> [Directory]
+ System.GPIO.Linux.Sysfs.Mock.Internal: cd :: FilePath -> MockFSZipper -> Either IOError MockFSZipper
+ System.GPIO.Linux.Sysfs.Mock.Internal: data DirNode
+ System.GPIO.Linux.Sysfs.Mock.Internal: data File
+ System.GPIO.Linux.Sysfs.Mock.Internal: data FileType
+ System.GPIO.Linux.Sysfs.Mock.Internal: data MockFSCrumb
+ System.GPIO.Linux.Sysfs.Mock.Internal: data MockFSZipper
+ System.GPIO.Linux.Sysfs.Mock.Internal: dirName :: Directory -> Name
+ System.GPIO.Linux.Sysfs.Mock.Internal: dirNode :: Directory -> DirNode
+ System.GPIO.Linux.Sysfs.Mock.Internal: directory :: Name -> [File] -> [Directory] -> Directory
+ System.GPIO.Linux.Sysfs.Mock.Internal: files :: Directory -> [File]
+ System.GPIO.Linux.Sysfs.Mock.Internal: findFile :: Name -> Directory -> Maybe FileType
+ System.GPIO.Linux.Sysfs.Mock.Internal: instance GHC.Classes.Eq System.GPIO.Linux.Sysfs.Mock.Internal.DirNode
+ System.GPIO.Linux.Sysfs.Mock.Internal: instance GHC.Classes.Eq System.GPIO.Linux.Sysfs.Mock.Internal.File
+ System.GPIO.Linux.Sysfs.Mock.Internal: instance GHC.Classes.Eq System.GPIO.Linux.Sysfs.Mock.Internal.FileType
+ System.GPIO.Linux.Sysfs.Mock.Internal: instance GHC.Classes.Eq System.GPIO.Linux.Sysfs.Mock.Internal.MockFSCrumb
+ System.GPIO.Linux.Sysfs.Mock.Internal: instance GHC.Classes.Eq System.GPIO.Linux.Sysfs.Mock.Internal.MockFSZipper
+ System.GPIO.Linux.Sysfs.Mock.Internal: instance GHC.Show.Show System.GPIO.Linux.Sysfs.Mock.Internal.DirNode
+ System.GPIO.Linux.Sysfs.Mock.Internal: instance GHC.Show.Show System.GPIO.Linux.Sysfs.Mock.Internal.File
+ System.GPIO.Linux.Sysfs.Mock.Internal: instance GHC.Show.Show System.GPIO.Linux.Sysfs.Mock.Internal.FileType
+ System.GPIO.Linux.Sysfs.Mock.Internal: instance GHC.Show.Show System.GPIO.Linux.Sysfs.Mock.Internal.MockFSCrumb
+ System.GPIO.Linux.Sysfs.Mock.Internal: instance GHC.Show.Show System.GPIO.Linux.Sysfs.Mock.Internal.MockFSZipper
+ System.GPIO.Linux.Sysfs.Mock.Internal: mkdir :: Name -> MockFSZipper -> Either IOError MockFSZipper
+ System.GPIO.Linux.Sysfs.Mock.Internal: mkfile :: Name -> FileType -> Bool -> MockFSZipper -> Either IOError MockFSZipper
+ System.GPIO.Linux.Sysfs.Mock.Internal: pathFromRoot :: MockFSZipper -> FilePath
+ System.GPIO.Linux.Sysfs.Mock.Internal: rmdir :: Name -> MockFSZipper -> Either IOError MockFSZipper
+ System.GPIO.Linux.Sysfs.Mock.Internal: rmfile :: Name -> MockFSZipper -> Either IOError MockFSZipper
+ System.GPIO.Linux.Sysfs.Mock.Internal: subdirs :: Directory -> [Directory]
+ System.GPIO.Linux.Sysfs.Mock.Internal: type Directory = Tree DirNode
+ System.GPIO.Linux.Sysfs.Mock.Internal: type Name = FilePath
+ System.GPIO.Linux.Sysfs.Monad: instance (Control.Monad.Catch.MonadMask m, System.GPIO.Linux.Sysfs.Monad.ThrowCatchSysfsM m) => System.GPIO.Monad.MonadGpio System.GPIO.Linux.Sysfs.Monad.PinDescriptor (System.GPIO.Linux.Sysfs.Monad.SysfsGpioT m)
+ System.GPIO.Linux.Sysfs.Monad: instance Control.Monad.Base.MonadBase b m => Control.Monad.Base.MonadBase b (System.GPIO.Linux.Sysfs.Monad.SysfsGpioT m)
+ System.GPIO.Linux.Sysfs.Monad: instance Control.Monad.Logger.MonadLogger m => Control.Monad.Logger.MonadLogger (System.GPIO.Linux.Sysfs.Monad.SysfsGpioT m)
+ System.GPIO.Linux.Sysfs.Monad: instance Control.Monad.Logger.MonadLoggerIO m => Control.Monad.Logger.MonadLoggerIO (System.GPIO.Linux.Sysfs.Monad.SysfsGpioT m)
+ System.GPIO.Linux.Sysfs.Monad: instance Control.Monad.Trans.Control.MonadBaseControl b m => Control.Monad.Trans.Control.MonadBaseControl b (System.GPIO.Linux.Sysfs.Monad.SysfsGpioT m)
+ System.GPIO.Linux.Sysfs.Monad: instance Control.Monad.Trans.Control.MonadTransControl System.GPIO.Linux.Sysfs.Monad.SysfsGpioT
+ System.GPIO.Linux.Sysfs.Monad: instance System.GPIO.Linux.Sysfs.Monad.MonadSysfs m => System.GPIO.Linux.Sysfs.Monad.MonadSysfs (Control.Monad.Logger.LoggingT m)
+ System.GPIO.Linux.Sysfs.Monad: instance System.GPIO.Linux.Sysfs.Monad.MonadSysfs m => System.GPIO.Linux.Sysfs.Monad.MonadSysfs (Control.Monad.Logger.NoLoggingT m)
+ System.GPIO.Linux.Sysfs.Monad: type CatchSysfsM m = (Functor m, MonadCatch m, MonadSysfs m)
+ System.GPIO.Linux.Sysfs.Monad: type ThrowCatchSysfsM m = (Functor m, MonadThrow m, MonadCatch m, MonadSysfs m)
+ System.GPIO.Linux.Sysfs.Monad: type ThrowSysfsM m = (Functor m, MonadThrow m, MonadSysfs m)
+ System.GPIO.Monad: instance System.GPIO.Monad.MonadGpio h m => System.GPIO.Monad.MonadGpio h (Control.Monad.Logger.LoggingT m)
+ System.GPIO.Monad: instance System.GPIO.Monad.MonadGpio h m => System.GPIO.Monad.MonadGpio h (Control.Monad.Logger.NoLoggingT m)
+ System.GPIO.Monad: type MaskGpioM h m = (MonadMask m, MonadGpio h m)
+ System.GPIO.Monad: type ThrowGpioM h m = (MonadThrow m, MonadGpio h m)
- System.GPIO.Linux.Sysfs: InternalError :: String -> SysfsException
+ System.GPIO.Linux.Sysfs: InternalError :: Text -> SysfsException
- System.GPIO.Linux.Sysfs: UnexpectedActiveLow :: Pin -> String -> SysfsException
+ System.GPIO.Linux.Sysfs: UnexpectedActiveLow :: Pin -> Text -> SysfsException
- System.GPIO.Linux.Sysfs: UnexpectedContents :: FilePath -> String -> SysfsException
+ System.GPIO.Linux.Sysfs: UnexpectedContents :: FilePath -> Text -> SysfsException
- System.GPIO.Linux.Sysfs: UnexpectedDirection :: Pin -> String -> SysfsException
+ System.GPIO.Linux.Sysfs: UnexpectedDirection :: Pin -> Text -> SysfsException
- System.GPIO.Linux.Sysfs: UnexpectedEdge :: Pin -> String -> SysfsException
+ System.GPIO.Linux.Sysfs: UnexpectedEdge :: Pin -> Text -> SysfsException
- System.GPIO.Linux.Sysfs: UnexpectedValue :: Pin -> String -> SysfsException
+ System.GPIO.Linux.Sysfs: UnexpectedValue :: Pin -> Text -> SysfsException
- System.GPIO.Linux.Sysfs: availablePins :: (MonadSysfs m, MonadThrow m, MonadCatch m) => m [Pin]
+ System.GPIO.Linux.Sysfs: availablePins :: (ThrowCatchSysfsM m) => m [Pin]
- System.GPIO.Linux.Sysfs: class (Monad m) => MonadSysfs m
+ System.GPIO.Linux.Sysfs: class (Monad m) => MonadSysfs 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
- System.GPIO.Linux.Sysfs: doesDirectoryExist :: MonadSysfs m => FilePath -> m Bool
+ System.GPIO.Linux.Sysfs: doesDirectoryExist :: (MonadSysfs m, MonadTrans t, MonadSysfs m', t m' ~ m) => FilePath -> m Bool
- System.GPIO.Linux.Sysfs: doesFileExist :: MonadSysfs m => FilePath -> m Bool
+ System.GPIO.Linux.Sysfs: doesFileExist :: (MonadSysfs m, MonadTrans t, MonadSysfs m', t m' ~ m) => FilePath -> m Bool
- System.GPIO.Linux.Sysfs: exportPin :: (MonadSysfs m, MonadCatch m) => Pin -> m ()
+ System.GPIO.Linux.Sysfs: exportPin :: (CatchSysfsM m) => Pin -> m ()
- System.GPIO.Linux.Sysfs: exportPinChecked :: (MonadCatch m, MonadSysfs m) => Pin -> m ()
+ System.GPIO.Linux.Sysfs: exportPinChecked :: (CatchSysfsM m) => Pin -> m ()
- System.GPIO.Linux.Sysfs: getDirectoryContents :: MonadSysfs m => FilePath -> m [FilePath]
+ System.GPIO.Linux.Sysfs: getDirectoryContents :: (MonadSysfs m, MonadTrans t, MonadSysfs m', t m' ~ m) => FilePath -> m [FilePath]
- System.GPIO.Linux.Sysfs: pinHasDirection :: (MonadSysfs m, MonadThrow m) => Pin -> m Bool
+ System.GPIO.Linux.Sysfs: pinHasDirection :: (ThrowSysfsM m) => Pin -> m Bool
- System.GPIO.Linux.Sysfs: pinHasEdge :: (MonadSysfs m, MonadThrow m) => Pin -> m Bool
+ System.GPIO.Linux.Sysfs: pinHasEdge :: (ThrowSysfsM m) => Pin -> m Bool
- System.GPIO.Linux.Sysfs: pollFile :: MonadSysfs m => FilePath -> Int -> m CInt
+ System.GPIO.Linux.Sysfs: pollFile :: (MonadSysfs m, MonadTrans t, MonadSysfs m', t m' ~ m) => FilePath -> Int -> m CInt
- System.GPIO.Linux.Sysfs: pollPinValue :: (Functor m, MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> m PinValue
+ System.GPIO.Linux.Sysfs: pollPinValue :: (ThrowCatchSysfsM m) => Pin -> m PinValue
- System.GPIO.Linux.Sysfs: pollPinValueTimeout :: (Functor m, MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> Int -> m (Maybe PinValue)
+ System.GPIO.Linux.Sysfs: pollPinValueTimeout :: (ThrowCatchSysfsM m) => Pin -> Int -> m (Maybe PinValue)
- System.GPIO.Linux.Sysfs: readFile :: MonadSysfs m => FilePath -> m ByteString
+ System.GPIO.Linux.Sysfs: readFile :: (MonadSysfs m, MonadTrans t, MonadSysfs m', t m' ~ m) => FilePath -> m ByteString
- System.GPIO.Linux.Sysfs: readPinActiveLow :: (MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> m Bool
+ System.GPIO.Linux.Sysfs: readPinActiveLow :: (ThrowCatchSysfsM m) => Pin -> m Bool
- System.GPIO.Linux.Sysfs: readPinDirection :: (MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> m PinDirection
+ System.GPIO.Linux.Sysfs: readPinDirection :: (ThrowCatchSysfsM m) => Pin -> m PinDirection
- System.GPIO.Linux.Sysfs: readPinEdge :: (MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> m SysfsEdge
+ System.GPIO.Linux.Sysfs: readPinEdge :: (ThrowCatchSysfsM m) => Pin -> m SysfsEdge
- System.GPIO.Linux.Sysfs: readPinValue :: (MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> m PinValue
+ System.GPIO.Linux.Sysfs: readPinValue :: (ThrowCatchSysfsM m) => Pin -> m PinValue
- System.GPIO.Linux.Sysfs: unexportPin :: (MonadSysfs m, MonadCatch m) => Pin -> m ()
+ System.GPIO.Linux.Sysfs: unexportPin :: (CatchSysfsM m) => Pin -> m ()
- System.GPIO.Linux.Sysfs: unexportPinChecked :: (MonadSysfs m, MonadCatch m) => Pin -> m ()
+ System.GPIO.Linux.Sysfs: unexportPinChecked :: (CatchSysfsM m) => Pin -> m ()
- System.GPIO.Linux.Sysfs: unlockedWriteFile :: MonadSysfs m => FilePath -> ByteString -> m ()
+ System.GPIO.Linux.Sysfs: unlockedWriteFile :: (MonadSysfs m, MonadTrans t, MonadSysfs m', t m' ~ m) => FilePath -> ByteString -> m ()
- System.GPIO.Linux.Sysfs: writeFile :: MonadSysfs m => FilePath -> ByteString -> m ()
+ System.GPIO.Linux.Sysfs: writeFile :: (MonadSysfs m, MonadTrans t, MonadSysfs m', t m' ~ m) => FilePath -> ByteString -> m ()
- System.GPIO.Linux.Sysfs: writePinActiveLow :: (MonadSysfs m, MonadCatch m) => Pin -> Bool -> m ()
+ System.GPIO.Linux.Sysfs: writePinActiveLow :: (CatchSysfsM m) => Pin -> Bool -> m ()
- System.GPIO.Linux.Sysfs: writePinDirection :: (MonadSysfs m, MonadCatch m) => Pin -> PinDirection -> m ()
+ System.GPIO.Linux.Sysfs: writePinDirection :: (CatchSysfsM m) => Pin -> PinDirection -> m ()
- System.GPIO.Linux.Sysfs: writePinDirectionWithValue :: (MonadSysfs m, MonadCatch m) => Pin -> PinValue -> m ()
+ System.GPIO.Linux.Sysfs: writePinDirectionWithValue :: (CatchSysfsM m) => Pin -> PinValue -> m ()
- System.GPIO.Linux.Sysfs: writePinEdge :: (MonadSysfs m, MonadCatch m) => Pin -> SysfsEdge -> m ()
+ System.GPIO.Linux.Sysfs: writePinEdge :: (CatchSysfsM m) => Pin -> SysfsEdge -> m ()
- System.GPIO.Linux.Sysfs: writePinValue :: (MonadSysfs m, MonadCatch m) => Pin -> PinValue -> m ()
+ System.GPIO.Linux.Sysfs: writePinValue :: (CatchSysfsM m) => Pin -> PinValue -> m ()
- System.GPIO.Linux.Sysfs.Mock: InternalError :: String -> MockFSException
+ System.GPIO.Linux.Sysfs.Mock: InternalError :: Text -> MockFSException
- System.GPIO.Linux.Sysfs.Mock: MockGpioChip :: !String -> !Int -> [MockPinState] -> MockGpioChip
+ System.GPIO.Linux.Sysfs.Mock: MockGpioChip :: !Text -> !Int -> [MockPinState] -> MockGpioChip
- System.GPIO.Linux.Sysfs.Mock: [_label] :: MockGpioChip -> !String
+ System.GPIO.Linux.Sysfs.Mock: [_label] :: MockGpioChip -> !Text
- System.GPIO.Linux.Sysfs.Mock: doesDirectoryExist :: (Monad m) => FilePath -> SysfsMockT m Bool
+ System.GPIO.Linux.Sysfs.Mock: doesDirectoryExist :: (MockM m) => FilePath -> SysfsMockT m Bool
- System.GPIO.Linux.Sysfs.Mock: doesFileExist :: (Monad m) => FilePath -> SysfsMockT m Bool
+ System.GPIO.Linux.Sysfs.Mock: doesFileExist :: (MockM m) => FilePath -> SysfsMockT m Bool
- System.GPIO.Linux.Sysfs.Mock: evalSysfsMockT :: (Functor m, MonadThrow m) => SysfsMockT m a -> MockWorld -> [MockGpioChip] -> m a
+ System.GPIO.Linux.Sysfs.Mock: evalSysfsMockT :: (MockM m) => SysfsMockT m a -> MockWorld -> [MockGpioChip] -> m a
- System.GPIO.Linux.Sysfs.Mock: execSysfsMockT :: (Functor m, MonadThrow m) => SysfsMockT m a -> MockWorld -> [MockGpioChip] -> m MockWorld
+ System.GPIO.Linux.Sysfs.Mock: execSysfsMockT :: (MockM m) => SysfsMockT m a -> MockWorld -> [MockGpioChip] -> m MockWorld
- System.GPIO.Linux.Sysfs.Mock: getDirectoryContents :: (Functor m, MonadThrow m) => FilePath -> SysfsMockT m [FilePath]
+ System.GPIO.Linux.Sysfs.Mock: getDirectoryContents :: (MockM m) => FilePath -> SysfsMockT m [FilePath]
- System.GPIO.Linux.Sysfs.Mock: pollFile :: (Monad m) => FilePath -> Int -> SysfsMockT m CInt
+ System.GPIO.Linux.Sysfs.Mock: pollFile :: (MockM m) => FilePath -> Int -> SysfsMockT m CInt
- System.GPIO.Linux.Sysfs.Mock: readFile :: (Functor m, MonadThrow m) => FilePath -> SysfsMockT m ByteString
+ System.GPIO.Linux.Sysfs.Mock: readFile :: (MockM m) => FilePath -> SysfsMockT m ByteString
- System.GPIO.Linux.Sysfs.Mock: runSysfsMockT :: (Functor m, MonadThrow m) => SysfsMockT m a -> MockWorld -> [MockGpioChip] -> m (a, MockWorld)
+ System.GPIO.Linux.Sysfs.Mock: runSysfsMockT :: (MockM m) => SysfsMockT m a -> MockWorld -> [MockGpioChip] -> m (a, MockWorld)
- System.GPIO.Linux.Sysfs.Mock: unlockedWriteFile :: (Functor m, MonadThrow m) => FilePath -> ByteString -> SysfsMockT m ()
+ System.GPIO.Linux.Sysfs.Mock: unlockedWriteFile :: (MockM m) => FilePath -> ByteString -> SysfsMockT m ()
- System.GPIO.Linux.Sysfs.Mock: writeFile :: (Functor m, MonadThrow m) => FilePath -> ByteString -> SysfsMockT m ()
+ System.GPIO.Linux.Sysfs.Mock: writeFile :: (MockM m) => FilePath -> ByteString -> SysfsMockT m ()
- System.GPIO.Linux.Sysfs.Monad: availablePins :: (MonadSysfs m, MonadThrow m, MonadCatch m) => m [Pin]
+ System.GPIO.Linux.Sysfs.Monad: availablePins :: (ThrowCatchSysfsM m) => m [Pin]
- System.GPIO.Linux.Sysfs.Monad: class (Monad m) => MonadSysfs m
+ System.GPIO.Linux.Sysfs.Monad: class (Monad m) => MonadSysfs 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
- System.GPIO.Linux.Sysfs.Monad: doesDirectoryExist :: MonadSysfs m => FilePath -> m Bool
+ System.GPIO.Linux.Sysfs.Monad: doesDirectoryExist :: (MonadSysfs m, MonadTrans t, MonadSysfs m', t m' ~ m) => FilePath -> m Bool
- System.GPIO.Linux.Sysfs.Monad: doesFileExist :: MonadSysfs m => FilePath -> m Bool
+ System.GPIO.Linux.Sysfs.Monad: doesFileExist :: (MonadSysfs m, MonadTrans t, MonadSysfs m', t m' ~ m) => FilePath -> m Bool
- System.GPIO.Linux.Sysfs.Monad: exportPin :: (MonadSysfs m, MonadCatch m) => Pin -> m ()
+ System.GPIO.Linux.Sysfs.Monad: exportPin :: (CatchSysfsM m) => Pin -> m ()
- System.GPIO.Linux.Sysfs.Monad: exportPinChecked :: (MonadCatch m, MonadSysfs m) => Pin -> m ()
+ System.GPIO.Linux.Sysfs.Monad: exportPinChecked :: (CatchSysfsM m) => Pin -> m ()
- System.GPIO.Linux.Sysfs.Monad: getDirectoryContents :: MonadSysfs m => FilePath -> m [FilePath]
+ System.GPIO.Linux.Sysfs.Monad: getDirectoryContents :: (MonadSysfs m, MonadTrans t, MonadSysfs m', t m' ~ m) => FilePath -> m [FilePath]
- System.GPIO.Linux.Sysfs.Monad: pinHasDirection :: (MonadSysfs m, MonadThrow m) => Pin -> m Bool
+ System.GPIO.Linux.Sysfs.Monad: pinHasDirection :: (ThrowSysfsM m) => Pin -> m Bool
- System.GPIO.Linux.Sysfs.Monad: pinHasEdge :: (MonadSysfs m, MonadThrow m) => Pin -> m Bool
+ System.GPIO.Linux.Sysfs.Monad: pinHasEdge :: (ThrowSysfsM m) => Pin -> m Bool
- System.GPIO.Linux.Sysfs.Monad: pollFile :: MonadSysfs m => FilePath -> Int -> m CInt
+ System.GPIO.Linux.Sysfs.Monad: pollFile :: (MonadSysfs m, MonadTrans t, MonadSysfs m', t m' ~ m) => FilePath -> Int -> m CInt
- System.GPIO.Linux.Sysfs.Monad: pollPinValue :: (Functor m, MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> m PinValue
+ System.GPIO.Linux.Sysfs.Monad: pollPinValue :: (ThrowCatchSysfsM m) => Pin -> m PinValue
- System.GPIO.Linux.Sysfs.Monad: pollPinValueTimeout :: (Functor m, MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> Int -> m (Maybe PinValue)
+ System.GPIO.Linux.Sysfs.Monad: pollPinValueTimeout :: (ThrowCatchSysfsM m) => Pin -> Int -> m (Maybe PinValue)
- System.GPIO.Linux.Sysfs.Monad: readFile :: MonadSysfs m => FilePath -> m ByteString
+ System.GPIO.Linux.Sysfs.Monad: readFile :: (MonadSysfs m, MonadTrans t, MonadSysfs m', t m' ~ m) => FilePath -> m ByteString
- System.GPIO.Linux.Sysfs.Monad: readPinActiveLow :: (MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> m Bool
+ System.GPIO.Linux.Sysfs.Monad: readPinActiveLow :: (ThrowCatchSysfsM m) => Pin -> m Bool
- System.GPIO.Linux.Sysfs.Monad: readPinDirection :: (MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> m PinDirection
+ System.GPIO.Linux.Sysfs.Monad: readPinDirection :: (ThrowCatchSysfsM m) => Pin -> m PinDirection
- System.GPIO.Linux.Sysfs.Monad: readPinEdge :: (MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> m SysfsEdge
+ System.GPIO.Linux.Sysfs.Monad: readPinEdge :: (ThrowCatchSysfsM m) => Pin -> m SysfsEdge
- System.GPIO.Linux.Sysfs.Monad: readPinValue :: (MonadSysfs m, MonadThrow m, MonadCatch m) => Pin -> m PinValue
+ System.GPIO.Linux.Sysfs.Monad: readPinValue :: (ThrowCatchSysfsM m) => Pin -> m PinValue
- System.GPIO.Linux.Sysfs.Monad: unexportPin :: (MonadSysfs m, MonadCatch m) => Pin -> m ()
+ System.GPIO.Linux.Sysfs.Monad: unexportPin :: (CatchSysfsM m) => Pin -> m ()
- System.GPIO.Linux.Sysfs.Monad: unexportPinChecked :: (MonadSysfs m, MonadCatch m) => Pin -> m ()
+ System.GPIO.Linux.Sysfs.Monad: unexportPinChecked :: (CatchSysfsM m) => Pin -> m ()
- System.GPIO.Linux.Sysfs.Monad: unlockedWriteFile :: MonadSysfs m => FilePath -> ByteString -> m ()
+ System.GPIO.Linux.Sysfs.Monad: unlockedWriteFile :: (MonadSysfs m, MonadTrans t, MonadSysfs m', t m' ~ m) => FilePath -> ByteString -> m ()
- System.GPIO.Linux.Sysfs.Monad: writeFile :: MonadSysfs m => FilePath -> ByteString -> m ()
+ System.GPIO.Linux.Sysfs.Monad: writeFile :: (MonadSysfs m, MonadTrans t, MonadSysfs m', t m' ~ m) => FilePath -> ByteString -> m ()
- System.GPIO.Linux.Sysfs.Monad: writePinActiveLow :: (MonadSysfs m, MonadCatch m) => Pin -> Bool -> m ()
+ System.GPIO.Linux.Sysfs.Monad: writePinActiveLow :: (CatchSysfsM m) => Pin -> Bool -> m ()
- System.GPIO.Linux.Sysfs.Monad: writePinDirection :: (MonadSysfs m, MonadCatch m) => Pin -> PinDirection -> m ()
+ System.GPIO.Linux.Sysfs.Monad: writePinDirection :: (CatchSysfsM m) => Pin -> PinDirection -> m ()
- System.GPIO.Linux.Sysfs.Monad: writePinDirectionWithValue :: (MonadSysfs m, MonadCatch m) => Pin -> PinValue -> m ()
+ System.GPIO.Linux.Sysfs.Monad: writePinDirectionWithValue :: (CatchSysfsM m) => Pin -> PinValue -> m ()
- System.GPIO.Linux.Sysfs.Monad: writePinEdge :: (MonadSysfs m, MonadCatch m) => Pin -> SysfsEdge -> m ()
+ System.GPIO.Linux.Sysfs.Monad: writePinEdge :: (CatchSysfsM m) => Pin -> SysfsEdge -> m ()
- System.GPIO.Linux.Sysfs.Monad: writePinValue :: (MonadSysfs m, MonadCatch m) => Pin -> PinValue -> m ()
+ System.GPIO.Linux.Sysfs.Monad: writePinValue :: (CatchSysfsM m) => Pin -> PinValue -> m ()
- System.GPIO.Linux.Sysfs.Types: InternalError :: String -> SysfsException
+ System.GPIO.Linux.Sysfs.Types: InternalError :: Text -> SysfsException
- System.GPIO.Linux.Sysfs.Types: UnexpectedActiveLow :: Pin -> String -> SysfsException
+ System.GPIO.Linux.Sysfs.Types: UnexpectedActiveLow :: Pin -> Text -> SysfsException
- System.GPIO.Linux.Sysfs.Types: UnexpectedContents :: FilePath -> String -> SysfsException
+ System.GPIO.Linux.Sysfs.Types: UnexpectedContents :: FilePath -> Text -> SysfsException
- System.GPIO.Linux.Sysfs.Types: UnexpectedDirection :: Pin -> String -> SysfsException
+ System.GPIO.Linux.Sysfs.Types: UnexpectedDirection :: Pin -> Text -> SysfsException
- System.GPIO.Linux.Sysfs.Types: UnexpectedEdge :: Pin -> String -> SysfsException
+ System.GPIO.Linux.Sysfs.Types: UnexpectedEdge :: Pin -> Text -> SysfsException
- System.GPIO.Linux.Sysfs.Types: UnexpectedValue :: Pin -> String -> SysfsException
+ System.GPIO.Linux.Sysfs.Types: UnexpectedValue :: Pin -> Text -> SysfsException
- System.GPIO.Monad: class Monad m => MonadGpio h m | m -> h
+ System.GPIO.Monad: class Monad m => MonadGpio h m | m -> h 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 timeout = lift $ pollPinTimeout h timeout 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
- System.GPIO.Monad: closePin :: MonadGpio h m => h -> m ()
+ System.GPIO.Monad: closePin :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => h -> m ()
- System.GPIO.Monad: getInterruptPinInterruptMode :: (MonadThrow m, MonadGpio h m) => InterruptPin h -> m PinInterruptMode
+ System.GPIO.Monad: getInterruptPinInterruptMode :: (ThrowGpioM h m) => InterruptPin h -> m PinInterruptMode
- System.GPIO.Monad: getPinActiveLevel :: MonadGpio h m => h -> m PinActiveLevel
+ System.GPIO.Monad: getPinActiveLevel :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => h -> m PinActiveLevel
- System.GPIO.Monad: getPinDirection :: MonadGpio h m => h -> m PinDirection
+ System.GPIO.Monad: getPinDirection :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => h -> m PinDirection
- System.GPIO.Monad: getPinInputMode :: MonadGpio h m => h -> m PinInputMode
+ System.GPIO.Monad: getPinInputMode :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => h -> m PinInputMode
- System.GPIO.Monad: getPinInterruptMode :: MonadGpio h m => h -> m PinInterruptMode
+ System.GPIO.Monad: getPinInterruptMode :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => h -> m PinInterruptMode
- System.GPIO.Monad: getPinOutputMode :: MonadGpio h m => h -> m PinOutputMode
+ System.GPIO.Monad: getPinOutputMode :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => h -> m PinOutputMode
- System.GPIO.Monad: openPin :: MonadGpio h m => Pin -> m h
+ System.GPIO.Monad: openPin :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => Pin -> m h
- System.GPIO.Monad: pinCapabilities :: MonadGpio h m => Pin -> m PinCapabilities
+ System.GPIO.Monad: pinCapabilities :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => Pin -> m PinCapabilities
- System.GPIO.Monad: pins :: MonadGpio h m => m [Pin]
+ System.GPIO.Monad: pins :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => m [Pin]
- System.GPIO.Monad: pollPin :: MonadGpio h m => h -> m PinValue
+ System.GPIO.Monad: pollPin :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => h -> m PinValue
- System.GPIO.Monad: pollPinTimeout :: MonadGpio h m => h -> Int -> m (Maybe PinValue)
+ System.GPIO.Monad: pollPinTimeout :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => h -> Int -> m (Maybe PinValue)
- System.GPIO.Monad: readPin :: MonadGpio h m => h -> m PinValue
+ System.GPIO.Monad: readPin :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => h -> m PinValue
- System.GPIO.Monad: setPinActiveLevel :: MonadGpio h m => h -> PinActiveLevel -> m ()
+ System.GPIO.Monad: setPinActiveLevel :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => h -> PinActiveLevel -> m ()
- System.GPIO.Monad: setPinInputMode :: MonadGpio h m => h -> PinInputMode -> m ()
+ System.GPIO.Monad: setPinInputMode :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => h -> PinInputMode -> m ()
- System.GPIO.Monad: setPinInterruptMode :: MonadGpio h m => h -> PinInterruptMode -> m ()
+ System.GPIO.Monad: setPinInterruptMode :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => h -> PinInterruptMode -> m ()
- System.GPIO.Monad: setPinOutputMode :: MonadGpio h m => h -> PinOutputMode -> PinValue -> m ()
+ System.GPIO.Monad: setPinOutputMode :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => h -> PinOutputMode -> PinValue -> m ()
- System.GPIO.Monad: togglePin :: MonadGpio h m => h -> m PinValue
+ System.GPIO.Monad: togglePin :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => h -> m PinValue
- System.GPIO.Monad: togglePinActiveLevel :: MonadGpio h m => h -> m PinActiveLevel
+ System.GPIO.Monad: togglePinActiveLevel :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => h -> m PinActiveLevel
- System.GPIO.Monad: withInputPin :: (MonadMask m, MonadGpio h m) => Pin -> PinInputMode -> Maybe PinActiveLevel -> (InputPin h -> m a) -> m a
+ System.GPIO.Monad: withInputPin :: (MaskGpioM h m) => Pin -> PinInputMode -> Maybe PinActiveLevel -> (InputPin h -> m a) -> m a
- System.GPIO.Monad: withInterruptPin :: (MonadMask m, MonadGpio h m) => Pin -> PinInputMode -> PinInterruptMode -> Maybe PinActiveLevel -> (InterruptPin h -> m a) -> m a
+ System.GPIO.Monad: withInterruptPin :: (MaskGpioM h m) => Pin -> PinInputMode -> PinInterruptMode -> Maybe PinActiveLevel -> (InterruptPin h -> m a) -> m a
- System.GPIO.Monad: withOutputPin :: (MonadMask m, MonadGpio h m) => Pin -> PinOutputMode -> Maybe PinActiveLevel -> PinValue -> (OutputPin h -> m a) -> m a
+ System.GPIO.Monad: withOutputPin :: (MaskGpioM h m) => Pin -> PinOutputMode -> Maybe PinActiveLevel -> PinValue -> (OutputPin h -> m a) -> m a
- System.GPIO.Monad: withPin :: (MonadMask m, MonadGpio h m) => Pin -> (h -> m a) -> m a
+ System.GPIO.Monad: withPin :: (MaskGpioM h m) => Pin -> (h -> m a) -> m a
- System.GPIO.Monad: writePin :: MonadGpio h m => h -> PinValue -> m ()
+ System.GPIO.Monad: writePin :: (MonadGpio h m, MonadTrans t, MonadGpio h m', t m' ~ m) => h -> PinValue -> m ()
- System.GPIO.Tutorial: withInputPin :: (MonadMask m, MonadGpio h m) => Pin -> PinInputMode -> Maybe PinActiveLevel -> (InputPin h -> m a) -> m a
+ System.GPIO.Tutorial: withInputPin :: (MaskGpioM h m) => Pin -> PinInputMode -> Maybe PinActiveLevel -> (InputPin h -> m a) -> m a
- System.GPIO.Tutorial: withInterruptPin :: (MonadMask m, MonadGpio h m) => Pin -> PinInputMode -> PinInterruptMode -> Maybe PinActiveLevel -> (InterruptPin h -> m a) -> m a
+ System.GPIO.Tutorial: withInterruptPin :: (MaskGpioM h m) => Pin -> PinInputMode -> PinInterruptMode -> Maybe PinActiveLevel -> (InterruptPin h -> m a) -> m a
- System.GPIO.Tutorial: withOutputPin :: (MonadMask m, MonadGpio h m) => Pin -> PinOutputMode -> Maybe PinActiveLevel -> PinValue -> (OutputPin h -> m a) -> m a
+ System.GPIO.Tutorial: withOutputPin :: (MaskGpioM h m) => Pin -> PinOutputMode -> Maybe PinActiveLevel -> PinValue -> (OutputPin h -> m a) -> m a
Files
- .travis.yml +37/−31
- changelog.md +20/−0
- default.nix +14/−14
- examples/Gpio.hs +50/−41
- examples/GpioReader.hs +59/−50
- examples/Sysfs.hs +38/−34
- hpio.cabal +260/−246
- shell.nix +18/−23
- src/System/GPIO.hs +3/−6
- src/System/GPIO/Linux.hs +2/−3
- src/System/GPIO/Linux/Sysfs.hs +1/−0
- src/System/GPIO/Linux/Sysfs/IO.hs +47/−13
- src/System/GPIO/Linux/Sysfs/Mock.hs +100/−56
- src/System/GPIO/Linux/Sysfs/Mock/Internal.hs +4/−9
- src/System/GPIO/Linux/Sysfs/Monad.hs +144/−165
- src/System/GPIO/Linux/Sysfs/Types.hs +8/−9
- src/System/GPIO/Linux/Sysfs/Util.hs +2/−3
- src/System/GPIO/Monad.hs +91/−262
- src/System/GPIO/Tutorial.hs +3/−0
- src/System/GPIO/Types.hs +5/−7
- stack-lts-2.yaml +16/−3
- stack.yaml +3/−1
- test/Main.hs +0/−7
- test/Spec.hs +1/−1
- test/System/GPIO/Linux/Sysfs/LinuxBboneSpec.hs +0/−1144
- test/System/GPIO/Linux/Sysfs/MockInternalSpec.hs +0/−328
- test/System/GPIO/Linux/Sysfs/MockSpec.hs +0/−138
- test/System/GPIO/Linux/Sysfs/SysfsGpioMockSpec.hs +0/−879
- test/System/GPIO/TypesSpec.hs +0/−142
- test/Test/System/GPIO/Linux/Sysfs/LinuxBboneSpec.hs +1142/−0
- test/Test/System/GPIO/Linux/Sysfs/MockInternalSpec.hs +331/−0
- test/Test/System/GPIO/Linux/Sysfs/MockSpec.hs +137/−0
- test/Test/System/GPIO/Linux/Sysfs/SysfsGpioMockSpec.hs +878/−0
- test/Test/System/GPIO/TypesSpec.hs +144/−0
- test/doctest.hs +3/−6
- test/hlint.hs +1/−3
.travis.yml view
@@ -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 ;;
changelog.md view
@@ -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:
default.nix view
@@ -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; }
examples/Gpio.hs view
@@ -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
examples/GpioReader.hs view
@@ -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
examples/Sysfs.hs view
@@ -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
hpio.cabal view
@@ -1,260 +1,274 @@-Name: hpio-Version: 0.8.0.10-Cabal-Version: >= 1.10-Build-Type: Simple-Author: Drew Hess <dhess-src@quixoftic.com>-Maintainer: Drew Hess <dhess-src@quixoftic.com>-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 <dhess-src@quixoftic.com>+maintainer: Drew Hess <dhess-src@quixoftic.com>+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
shell.nix view
@@ -1,35 +1,35 @@-{ nixpkgs ? import <nixpkgs> {}, compiler ? "default" }:+{ nixpkgs ? import <nixpkgs> {}, 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
src/System/GPIO.hs view
@@ -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
src/System/GPIO/Linux.hs view
@@ -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
src/System/GPIO/Linux/Sysfs.hs view
@@ -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
src/System/GPIO/Linux/Sysfs/IO.hs view
@@ -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
src/System/GPIO/Linux/Sysfs/Mock.hs view
@@ -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.
src/System/GPIO/Linux/Sysfs/Mock/Internal.hs view
@@ -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
src/System/GPIO/Linux/Sysfs/Monad.hs view
@@ -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")
src/System/GPIO/Linux/Sysfs/Types.hs view
@@ -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
src/System/GPIO/Linux/Sysfs/Util.hs view
@@ -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
src/System/GPIO/Monad.hs view
@@ -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
src/System/GPIO/Tutorial.hs view
@@ -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
src/System/GPIO/Types.hs view
@@ -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
stack-lts-2.yaml view
@@ -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
stack.yaml view
@@ -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:
− test/Main.hs
@@ -1,7 +0,0 @@-module Main where--import Test.Hspec-import Spec--main :: IO ()-main = hspec spec
test/Spec.hs view
@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
− test/System/GPIO/Linux/Sysfs/LinuxBboneSpec.hs
@@ -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
− test/System/GPIO/Linux/Sysfs/MockInternalSpec.hs
@@ -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"
− test/System/GPIO/Linux/Sysfs/MockSpec.hs
@@ -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)
− test/System/GPIO/Linux/Sysfs/SysfsGpioMockSpec.hs
@@ -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}
− test/System/GPIO/TypesSpec.hs
@@ -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
+ test/Test/System/GPIO/Linux/Sysfs/LinuxBboneSpec.hs view
@@ -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
+ test/Test/System/GPIO/Linux/Sysfs/MockInternalSpec.hs view
@@ -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"
+ test/Test/System/GPIO/Linux/Sysfs/MockSpec.hs view
@@ -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)
+ test/Test/System/GPIO/Linux/Sysfs/SysfsGpioMockSpec.hs view
@@ -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}
+ test/Test/System/GPIO/TypesSpec.hs view
@@ -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
test/doctest.hs view
@@ -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)
test/hlint.hs view
@@ -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 =