diff --git a/app/Example.hs b/app/Example.hs new file mode 100644 --- /dev/null +++ b/app/Example.hs @@ -0,0 +1,38 @@ +module Main where + +import Control.Exception (bracket) +import Control.Lens ((^.)) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) + +import System.Hardware.ELM327 (connect) +import System.Hardware.ELM327.Commands (AT(..), Protocol(..)) +import System.Hardware.ELM327.Connection (Con, ConT, ConError, withCon, close', at) +import System.Hardware.ELM327.Car (Car, runCarT, defaultCar) +import qualified System.Hardware.ELM327.Car as Car + +main :: IO () +main = do + r <- bracket (either (fail . show) return =<< connect "/dev/ttyUSB0") + (\c -> putStrLn "Closing connection..." >> close' c) + query + either (fail . show) return r + +query :: Con -> IO (Either ConError ()) +query con = withCon con $ runCarT $ do + _ <- lift $ at (ATSelectProtocol AutomaticProtocol) + printI "ECT" $ car ^. Car.engineCoolantTemperature + printI "Fuel Rate" $ car ^. Car.engineFuelRate + printI "RPM" $ car ^. Car.engineRPM + printI "Air T." $ car ^. Car.intakeAirTemperature + printI "MAP" $ car ^. Car.intakeManifoldAbsolutePressure + printI "MAF" $ car ^. Car.massAirFlowRate + printI "Throttle" $ car ^. Car.throttlePosition + printI "Speed" $ car ^. Car.vehicleSpeed + where + car :: Car (ConT IO) + car = defaultCar + printI key value = do + v <- show <$> value + liftIO $ putStrLn $ key ++ ": " ++ v + diff --git a/app/Terminal.hs b/app/Terminal.hs --- a/app/Terminal.hs +++ b/app/Terminal.hs @@ -4,7 +4,6 @@ import Control.Exception (bracket) import Control.Monad (join) import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask) import Control.Monad.Trans.Class (lift) import Data.List (isSuffixOf) import qualified Data.ByteString.Char8 as Char8 @@ -20,7 +19,7 @@ controlIO, runInputT, defaultSettings, getInputLine) -import System.Hardware.ELM327.Connection (Con, recv, sendString) +import System.Hardware.ELM327.Connection (Con, ConT, ConError, withCon, recv, sendString) import System.Hardware.ELM327.Simulator (defaultSimulator) import System.Hardware.ELM327.Simulator.OBDBus.VWPolo2007 (stoppedCarBus) import qualified System.Hardware.ELM327.Connection as Connection @@ -28,10 +27,10 @@ import qualified System.Hardware.ELM327.Simulator as Simulator -newtype Term a = Term { runTerm :: ReaderT Con IO a } - deriving (Functor, Applicative, Monad, MonadIO, MonadReader Con) +newtype TermT a = TermT { runTermT :: ConT IO a } + deriving (Functor, Applicative, Monad, MonadIO) -instance MonadException Term where +instance MonadException TermT where controlIO f = join . liftIO $ f (RunIO return) data ConnectionType = ConnectionTypeActualDevice FilePath @@ -51,36 +50,37 @@ p = helper <*> connectionType connect :: ConnectionType -> IO Con -connect ConnectionTypeSimulator = Simulator.connect $ defaultSimulator stoppedCarBus -connect (ConnectionTypeActualDevice dev) = ELM327.connect dev +connect ConnectionTypeSimulator = Simulator.connect (defaultSimulator stoppedCarBus) +connect (ConnectionTypeActualDevice dev) = either (\e -> fail $ "could not connect: " ++ show e) return =<< ELM327.connect dev runTerminal :: ConnectionType -> IO () -runTerminal ct = bracket (connect ct) - (\c -> putStrLn "Closing connection..." >> Connection.close c) - (liftIO . runTerminalWithConnection) +runTerminal ct = do + r <- bracket (connect ct) + (\c -> putStrLn "Closing connection..." >> Connection.close' c) + (liftIO . runTerminalWithConnection) + either (\e -> fail $ "error: " ++ show e) return r -runTerminalWithConnection :: Con -> IO () -runTerminalWithConnection = runReaderT (runTerm readEvalPrint) +runTerminalWithConnection :: Con -> IO (Either ConError ()) +runTerminalWithConnection con = withCon con (runTermT readEvalPrint) -readEvalPrint :: Term () +readEvalPrint :: TermT () readEvalPrint = runInputT defaultSettings loop where - loop :: InputT Term () + loop :: InputT TermT () loop = do maybeLine <- getInputLine "% " case maybeLine of Nothing -> return () Just ":exit" -> return () Just x -> handleLine x >> loop -handleLine :: String -> InputT Term () +handleLine :: String -> InputT TermT () handleLine cmd = do - con <- lift ask - liftIO $ sendString con $ cmd ++ "\r" + lift $ TermT . sendString $ cmd ++ "\r" printAll -printAll :: InputT Term () +printAll :: InputT TermT () printAll = do - maybeBS <- lift ask >>= liftIO . recv + maybeBS <- lift $ TermT recv case maybeBS of Nothing -> return () Just b -> liftIO . putStrLn $ convertResponse b where diff --git a/obd.cabal b/obd.cabal --- a/obd.cabal +++ b/obd.cabal @@ -1,5 +1,5 @@ name: obd -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Communicate to OBD interfaces over ELM327 description: Haskell library to communicate with OBD-II over ELM327, @@ -58,6 +58,17 @@ , haskeline >= 0.7.2.3 && < 0.8 , mtl >= 2.2.1 && < 2.3 , optparse-applicative >= 0.12.1.0 && < 0.13 + , transformers >= 0.4.2.0 && < 0.5 + default-language: Haskell2010 + default-extensions: OverloadedStrings + +executable obd-example + hs-source-dirs: app + main-is: Example.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: base + , obd + , lens >= 4.13 && < 4.14 , transformers >= 0.4.2.0 && < 0.5 default-language: Haskell2010 default-extensions: OverloadedStrings diff --git a/src/System/Hardware/ELM327.hs b/src/System/Hardware/ELM327.hs --- a/src/System/Hardware/ELM327.hs +++ b/src/System/Hardware/ELM327.hs @@ -15,24 +15,27 @@ import qualified System.Hardware.Serialport as Port import System.Hardware.ELM327.Commands (AT(..)) -import System.Hardware.ELM327.Connection (Con(..), at) +import System.Hardware.ELM327.Connection (Con(..), ConError, withCon, at) -- | Connect to an ELM327 device. -connect :: FilePath -> IO Con +connect :: FilePath -> IO (Either ConError Con) connect fp = do let s = SerialPortSettings { commSpeed = CS38400 , bitsPerWord = 8 , stopb = One , parity = NoParity , flowControl = NoFlowControl - , timeout = 2 } + , timeout = 5 {- 500ms -} } port <- openSerial fp s is <- makeInputStream (produce port) os <- makeOutputStream (consume port) - initialize $ Con is os (closeSerial port) + initialize $ Con is os where - produce port = Just <$> Port.recv port 8 - consume _ Nothing = return () + produce port = do + b <- Port.recv port 8 + if Char8.null b then return Nothing + else return $ Just b + consume port Nothing = closeSerial port consume port (Just x) = sendAll port x sendAll port bs @@ -41,6 +44,8 @@ sendAll port $ Char8.drop sent bs initialize con = do - _ <- at con ATResetAll - _ <- at con ATEchoOff - return con + v <- withCon con $ do + _ <- at ATResetAll + _ <- at ATEchoOff + return () + return (v >> return con) diff --git a/src/System/Hardware/ELM327/Car.hs b/src/System/Hardware/ELM327/Car.hs --- a/src/System/Hardware/ELM327/Car.hs +++ b/src/System/Hardware/ELM327/Car.hs @@ -1,45 +1,134 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} -- | A generic car data type -module System.Hardware.ELM327.Car where +module System.Hardware.ELM327.Car ( + -- * Base car structure + Car +, defaultCar + -- * Monad transformer for cashing +, CarT(..) +, runCarT +, flushCache +, cache + + -- * Lenses for 'Car' +, engineCoolantTemperature +, engineFuelRate +, engineRPM +, intakeAirTemperature +, intakeManifoldAbsolutePressure +, massAirFlowRate +, throttlePosition +, vehicleSpeed + + -- * Internal structure +, CarState +, emptyState +) where + +import Control.Concurrent.STM (TVar, atomically, newTVarIO, readTVar, writeTVar, modifyTVar) +import Control.Lens (Lens', lens, (^.), (.~)) import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans.Either (EitherT(..), runEitherT) +import Control.Monad.Reader (ReaderT, MonadReader, runReaderT, ask) +import Control.Monad.Trans.Class (MonadTrans, lift) +import Control.Monad.Trans.Maybe (MaybeT(..)) import Numeric.Units.Dimensional.Prelude -import System.Hardware.ELM327.Connection (Con) -import System.Hardware.ELM327.Errors (OBDError) +import System.Hardware.ELM327.Connection (ConT) import qualified System.Hardware.ELM327.Connection.OBD as OBD --- | Some info about the car. -type I m a = m (Either OBDError a) +-- | A car that has some properties, see lenses documentation below. +data Car m = Car { _engineCoolantTemperature :: CarT m (ThermodynamicTemperature Double) + , _engineFuelRate :: CarT m (VolumeFlow Double) + , _engineRPM :: CarT m (Frequency Double) + , _intakeAirTemperature :: CarT m (ThermodynamicTemperature Double) + , _intakeManifoldAbsolutePressure :: CarT m (Pressure Double) + , _massAirFlowRate :: CarT m (MassFlow Double) + , _throttlePosition :: CarT m Double + , _vehicleSpeed :: CarT m (Velocity Double) } --- | A monad transform for information about the car. -infoT :: I m a -> EitherT OBDError m a -infoT = EitherT +-- | A monad transformer for 'Car' where requested data is cached until 'flushCache' is called. +newtype CarT m a = CarT { runCarT' :: ReaderT (TVar CarState) m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadReader (TVar CarState), MonadTrans) --- | Run the monad transform for inforamtion about the ar. -runInfoT :: EitherT OBDError m a -> I m a -runInfoT = runEitherT +-- | Run a 'CarT' with an initial empty state +runCarT :: MonadIO m => CarT m a -> m a +runCarT action = liftIO (newTVarIO emptyState) >>= runReaderT (runCarT' action) --- | A car that has some properties. -data Car m = Car { engineCoolantTemperature :: I m (ThermodynamicTemperature Double) - , engineFuelRate :: I m (VolumeFlow Double) - , engineRPM :: I m (Frequency Double) - , intakeAirTemperature :: I m (ThermodynamicTemperature Double) - , intakeManifoldAbsolutePressure :: I m (Pressure Double) - , massAirFlowRate :: I m (MassFlow Double) - , throttlePosition :: I m Double - , vehicleSpeed :: I m (Velocity Double) } +-- | Flush the cache of a 'CarT' +flushCache :: MonadIO m => CarT m () +flushCache = ask >>= liftIO . atomically . flip writeTVar emptyState +-- | Make an action cachable in 'CarT' +cache :: MonadIO m => (forall n . Lens' (Car n) (CarT n a)) -> CarT m a -> CarT m a +cache property action = do + mv <- runCarT . (^. property) <$> (ask >>= liftIO . atomically . readTVar) + v <- liftIO $ runMaybeT mv + case v of + Just x -> return x + Nothing -> do + v' <- action + ask >>= liftIO . atomically . flip modifyTVar (property .~ lift (MaybeT . return $ Just v')) + return v' + -- | The default car, that uses straight forward OBD commands to get -- most of the data. -defaultCar :: MonadIO m => Con -> Car m -defaultCar c = Car { engineCoolantTemperature = liftIO $ OBD.engineCoolantTemperature c - , engineFuelRate = liftIO $ OBD.engineFuelRate c - , engineRPM = liftIO $ OBD.engineRPM c - , intakeAirTemperature = liftIO $ OBD.intakeAirTemperature c - , intakeManifoldAbsolutePressure = liftIO $ OBD.intakeManifoldAbsolutePressure c - , massAirFlowRate = liftIO $ OBD.massAirFlowRate c - , throttlePosition = liftIO $ OBD.throttlePosition c - , vehicleSpeed = liftIO $ OBD.vehicleSpeed c } +defaultCar :: MonadIO m => Car (ConT m) +defaultCar = Car { _engineCoolantTemperature = cache engineCoolantTemperature (lift OBD.engineCoolantTemperature) + , _engineFuelRate = cache engineFuelRate (lift OBD.engineFuelRate) + , _engineRPM = cache engineRPM (lift OBD.engineRPM) + , _intakeAirTemperature = cache intakeAirTemperature (lift OBD.intakeAirTemperature) + , _intakeManifoldAbsolutePressure = cache intakeManifoldAbsolutePressure (lift OBD.intakeManifoldAbsolutePressure) + , _massAirFlowRate = cache massAirFlowRate (lift OBD.massAirFlowRate) + , _throttlePosition = cache throttlePosition (lift OBD.throttlePosition) + , _vehicleSpeed = cache vehicleSpeed (lift OBD.vehicleSpeed) } + +-- | The engine coolant temperature of the car. +engineCoolantTemperature :: Lens' (Car m) (CarT m (ThermodynamicTemperature Double)) +engineCoolantTemperature = lens _engineCoolantTemperature $ \c x -> c { _engineCoolantTemperature = x } + +-- | The engine fuel rate of the car. +engineFuelRate :: Lens' (Car m) (CarT m (VolumeFlow Double)) +engineFuelRate = lens _engineFuelRate $ \c x -> c { _engineFuelRate = x } + +-- | The engine RPM of the car. +engineRPM :: Lens' (Car m) (CarT m (Frequency Double)) +engineRPM = lens _engineRPM $ \c x -> c { _engineRPM = x } + +-- | The intake air temperature of the car. +intakeAirTemperature :: Lens' (Car m) (CarT m (ThermodynamicTemperature Double)) +intakeAirTemperature = lens _intakeAirTemperature $ \c x -> c { _intakeAirTemperature = x } + +-- | The intake manifold absolute pressure of the car. +intakeManifoldAbsolutePressure :: Lens' (Car m) (CarT m (Pressure Double)) +intakeManifoldAbsolutePressure = lens _intakeManifoldAbsolutePressure $ \c x -> c { _intakeManifoldAbsolutePressure = x } + +-- | The mass air flow rate of the car. +massAirFlowRate :: Lens' (Car m) (CarT m (MassFlow Double)) +massAirFlowRate = lens _massAirFlowRate $ \c x -> c { _massAirFlowRate = x } + +-- | The throttle position of the car. +throttlePosition :: Lens' (Car m) (CarT m Double) +throttlePosition = lens _throttlePosition $ \c x -> c { _throttlePosition = x } + +-- | The throttle position of the car. +vehicleSpeed :: Lens' (Car m) (CarT m (Velocity Double)) +vehicleSpeed = lens _vehicleSpeed $ \c x -> c { _vehicleSpeed = x } + +-- | The pure state of the car, with possibly missing values. +type CarState = Car (MaybeT IO) + +-- | The empty 'CarState' +emptyState :: CarState +emptyState = Car { _engineCoolantTemperature = lift (MaybeT $ return Nothing) + , _engineFuelRate = lift (MaybeT $ return Nothing) + , _engineRPM = lift (MaybeT $ return Nothing) + , _intakeAirTemperature = lift (MaybeT $ return Nothing) + , _intakeManifoldAbsolutePressure = lift (MaybeT $ return Nothing) + , _massAirFlowRate = lift (MaybeT $ return Nothing) + , _throttlePosition = lift (MaybeT $ return Nothing) + , _vehicleSpeed = lift (MaybeT $ return Nothing) } diff --git a/src/System/Hardware/ELM327/Car/MAP.hs b/src/System/Hardware/ELM327/Car/MAP.hs --- a/src/System/Hardware/ELM327/Car/MAP.hs +++ b/src/System/Hardware/ELM327/Car/MAP.hs @@ -2,17 +2,19 @@ -- | A car that uses the intake manifold absolute pressure (MAP) to -- calculate fuel consumption. module System.Hardware.ELM327.Car.MAP ( - MAPProperties + MAPProperties(..) , defaultProperties , mapCar ) where +import Control.Lens ((^. ), (.~)) import Control.Monad.IO.Class (MonadIO) import Numeric.Units.Dimensional.Prelude -import System.Hardware.ELM327.Connection (Con) -import System.Hardware.ELM327.Car (Car(..), I, infoT, runInfoT, defaultCar) +import System.Hardware.ELM327.Connection (ConT) +import System.Hardware.ELM327.Car (CarT, Car, defaultCar) +import qualified System.Hardware.ELM327.Car as Car -- | Some fixed values needed to implement a MAP car. @@ -31,19 +33,19 @@ -- | Create a car that uses the intake manifold absolute pressure (MAP) -- to calculate fuel consumption. -mapCar :: MonadIO m => Con -> MAPProperties ->Car m -mapCar con p = let c = defaultCar con in - c { engineFuelRate = engineFuelRate' p c - , massAirFlowRate = massAirFlowRate' p c} +mapCar :: MonadIO m => MAPProperties -> Car (ConT m) +mapCar p = (\c -> (Car.massAirFlowRate .~ massAirFlowRate' p c) c) . + (\c -> (Car.engineFuelRate .~ engineFuelRate' p c) c) $ + defaultCar -- | Calculate MAF from RPM, MAP and IAT -- -- See https://web.archive.org/web/20160323073219/http://www.lightner.net/obd2guru/IMAP_AFcalc.html -massAirFlowRate' :: Monad m => MAPProperties -> Car m -> I m (MassFlow Double) -massAirFlowRate' p c = runInfoT $ do - rpm <- infoT $ engineRPM c - map' <- infoT $ intakeManifoldAbsolutePressure c - iat <- infoT $ intakeAirTemperature c +massAirFlowRate' :: Monad m => MAPProperties -> Car m -> CarT m (MassFlow Double) +massAirFlowRate' p c = do + rpm <- c ^. Car.engineRPM + map' <- c ^. Car.intakeManifoldAbsolutePressure + iat <- c ^. Car.intakeAirTemperature let imap = rpm * map' / iat / (2 *~ one) let voleff = volumetricEfficiency p let displ = engineDisplacement p @@ -52,7 +54,7 @@ return $ imap * voleff * displ * mm / r -- | Calculate the engine fuel rate from MAF -engineFuelRate' :: Monad m => MAPProperties -> Car m -> I m (VolumeFlow Double) -engineFuelRate' p c = runInfoT $ do - maf <- infoT $ massAirFlowRate' p c +engineFuelRate' :: Monad m => MAPProperties -> Car m -> CarT m (VolumeFlow Double) +engineFuelRate' p c = do + maf <- c ^. Car.massAirFlowRate return $ maf / airFuelRatio p / fuelMassDensity p diff --git a/src/System/Hardware/ELM327/Connection.hs b/src/System/Hardware/ELM327/Connection.hs --- a/src/System/Hardware/ELM327/Connection.hs +++ b/src/System/Hardware/ELM327/Connection.hs @@ -1,7 +1,13 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} -- | Basic interface for communication with the ELM327. module System.Hardware.ELM327.Connection where import Control.Lens (re, (^.), (^?)) +import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader (ReaderT, MonadReader, runReaderT, ask) + import Data.ByteString.Char8 (ByteString) import Data.Char (isHexDigit) import Data.List (stripPrefix) @@ -22,73 +28,91 @@ OBDDecodeError(..), obdErrorMessage) import System.Hardware.ELM327.Utils.Hex (hexToBytes) -import System.Hardware.ELM327.Utils.Monad (maybeToLeft, maybeToRight) +import System.Hardware.ELM327.Utils.Monad (maybeToExcept, orThrow) -- | A connection to an ELM327 device that can be closed. -data Con = Con (InputStream ByteString) (OutputStream ByteString) (IO ()) +data Con = Con { conInput :: InputStream ByteString + , conOutput :: OutputStream ByteString } +-- | Monad transformer for connection operations. +newtype ConT m a = ConT { runConT :: ReaderT Con (ExceptT ConError m) a } + deriving (Functor, Applicative, Monad, MonadIO, MonadReader Con, MonadError ConError) + +-- | Run a 'ConT' +withCon :: Con -> ConT m a -> m (Either ConError a) +withCon con = runExceptT . flip runReaderT con . runConT + +-- | Errors that can occur in the 'ConT' monad. +data ConError = ConOBDError OBDError + | ConTimeoutError + deriving (Show) + -- | Close the connection -close :: Con -> IO () -close (Con _ _ c) = c +close :: MonadIO m => ConT m () +close = ask >>= close' +-- | Close the connection +close' :: MonadIO m => Con -> m () +close' = liftIO . Streams.write Nothing . conOutput + -- | Send an ELM327 command. -send :: Con -> Command -> IO () -send con cmd = do - sendString con $ cmd ^. re command - sendString con "\r" - flushOutputStream con +send :: MonadIO m => Command -> ConT m () +send cmd = do + sendString $ cmd ^. re command + sendString "\r" + flushOutputStream -- | Send all bytes to the ELM327. -sendBytes :: Con -> ByteString -> IO () -sendBytes (Con _ os _) x = Streams.write (Just x) os +sendBytes :: MonadIO m => ByteString -> ConT m () +sendBytes x = ask >>= liftIO . Streams.write (Just x) . conOutput -- | Send a string to the ELM327. -sendString :: Con -> String -> IO () -sendString con = sendBytes con . Char8.pack +sendString :: MonadIO m => String -> ConT m () +sendString = sendBytes . Char8.pack -- | Receive available ELM327 caracters as a byte string -recvRaw :: Con -> IO (Maybe ByteString) -recvRaw (Con is _ _) = Streams.read is +recvRaw :: MonadIO m => ConT m (Maybe ByteString) +recvRaw = ask >>= liftIO . Streams.read . conInput -- | Receive an ELM327 response as a byte string. -recv :: Con -> IO (Maybe ByteString) -recv (Con is _ _) = do +recv :: MonadIO m => ConT m (Maybe ByteString) +recv = do s <- Char8.concat . reverse <$> recv' [] if Char8.null s then return Nothing else return (Just s) where recv' xs = do - bs <- Streams.read is - case bs of Nothing -> recv' xs + bs <- ask >>= liftIO . Streams.read . conInput + case bs of Nothing -> throwError ConTimeoutError Just bs' -> handle' xs bs' handle' xs bs = let (pref, suf) = Char8.break (== '>') . Char8.filter (not . ignored) $ bs in if Char8.null suf then recv' (pref:xs) - else Streams.unRead (Char8.tail suf) is >> return (pref:xs) + else do ask >>= liftIO . Streams.unRead (Char8.tail suf) . conInput + return (pref:xs) ignored x = x == '\r' || x == '\0' -- | Flush the output stream of a connection. -flushOutputStream :: Con -> IO () -flushOutputStream (Con _ os _) = Streams.write (Just "") os +flushOutputStream :: MonadIO m => ConT m () +flushOutputStream = ask >>= liftIO. Streams.write (Just "") . conOutput -- | Send an 'AT' command and expect a response. -at :: Con -> AT -> IO (Maybe ByteString) -at con cmd = send con (AT cmd) >> recv con +at :: MonadIO m => AT -> ConT m (Maybe ByteString) +at cmd = send (AT cmd) >> recv -- | Send an 'OBD' comand and expect a response. -obd :: Con -> OBD -> IO (Either OBDError [Word8]) -obd con cmd = do - send con (OBD cmd) - mbs <- recv con +obd :: MonadIO m => OBD -> ConT m [Word8] +obd cmd = do + send (OBD cmd) + mbs <- recv case mbs of - Nothing -> return $ Left (OBDDecodeError EmptyResponseError) - Just bs -> return . decode $ Char8.unpack bs + Nothing -> throwError $ ConOBDError (OBDDecodeError EmptyResponseError) + Just bs -> decode $ Char8.unpack bs where - decode bs = Right (removeStatusPrefixes bs) - >>= \x -> maybeToLeft x (OBDErrorMessage <$> x ^? obdErrorMessage) - >>= Right . filter isHexDigit - >>= maybeToRight (OBDDecodeError NotEnoughBytesError) . hexToBytes - >>= maybeToRight (OBDDecodeError NoResponseHeaderError) . stripHeader + decode bs = let x = removeStatusPrefixes bs in + filter isHexDigit <$> maybeToExcept (ConOBDError . OBDErrorMessage <$> x ^? obdErrorMessage) x + >>= (`orThrow` ConOBDError (OBDDecodeError NotEnoughBytesError)) . hexToBytes + >>= (`orThrow` ConOBDError (OBDDecodeError NoResponseHeaderError)) . stripHeader statusPrefixes = ["SEARCHING..."] removeStatusPrefixes x = foldl stripPrefix' x statusPrefixes diff --git a/src/System/Hardware/ELM327/Connection/OBD.hs b/src/System/Hardware/ELM327/Connection/OBD.hs --- a/src/System/Hardware/ELM327/Connection/OBD.hs +++ b/src/System/Hardware/ELM327/Connection/OBD.hs @@ -1,65 +1,63 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE Rank2Types #-} -- | Send OBD requests to the connection and return a quantity. module System.Hardware.ELM327.Connection.OBD where import Control.Lens (Iso', re, (^.)) -import Control.Monad.Trans.Either (EitherT(..), left) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (MonadIO) import Numeric.Units.Dimensional.Prelude import System.Hardware.ELM327.Commands (OBD(..), CurrentData(..)) -import System.Hardware.ELM327.Connection (Con) +import System.Hardware.ELM327.Connection (ConT, ConError(..)) import System.Hardware.ELM327.Errors (OBDError(..), OBDDecodeError(..)) import qualified System.Hardware.ELM327.Connection as Connection import qualified System.Hardware.ELM327.OBD.Conversion as C - --- | Type alias for a request. -type Request a = Con -> IO (Either OBDError a) - -- | Get the engine coolant temperature. -engineCoolantTemperature :: Request (ThermodynamicTemperature Double) +engineCoolantTemperature :: MonadIO m => ConT m (ThermodynamicTemperature Double) engineCoolantTemperature = getOneByte OBDEngineCoolantTemperature C.engineCoolantTemperature -- | Get the engine fuel rate. -engineFuelRate :: Request (VolumeFlow Double) +engineFuelRate :: MonadIO m => ConT m (VolumeFlow Double) engineFuelRate = getTwoBytes OBDEngineFuelRate C.engineFuelRate -- | Get the engine RPM. -engineRPM :: Request (Frequency Double) +engineRPM :: MonadIO m => ConT m (Frequency Double) engineRPM = getTwoBytes OBDEngineRPM C.engineRPM -- | Get the intake air temperature. -intakeAirTemperature :: Request (ThermodynamicTemperature Double) +intakeAirTemperature :: MonadIO m => ConT m (ThermodynamicTemperature Double) intakeAirTemperature = getOneByte OBDIntakeAirTemperature C.intakeAirTemperature -- | Get the intake manifold absolute pressure -intakeManifoldAbsolutePressure :: Request (Pressure Double) +intakeManifoldAbsolutePressure :: MonadIO m => ConT m (Pressure Double) intakeManifoldAbsolutePressure = getOneByte OBDIntakeManifoldAbsolutePressure C.intakeManifoldAbsolutePressure -- | Get mass air flow rate. -massAirFlowRate :: Request (MassFlow Double) +massAirFlowRate :: MonadIO m => ConT m (MassFlow Double) massAirFlowRate = getTwoBytes OBDMassAirFlowRate C.massAirFlowRate -- | Get throttle position. -throttlePosition :: Request Double +throttlePosition :: MonadIO m => ConT m Double throttlePosition = getOneByte OBDThrottlePosition C.throttlePosition -- | Get vehicle speed. -vehicleSpeed :: Request (Velocity Double) +vehicleSpeed :: MonadIO m => ConT m (Velocity Double) vehicleSpeed = getOneByte OBDVehicleSpeed C.vehicleSpeed -- | Get one byte of data and convert it. -getOneByte :: CurrentData -> Iso' a C.OneByte -> Request a -getOneByte cmd conv con = runEitherT $ (^. re conv) <$> (oneByte =<< obd) - where obd = EitherT $ Connection.obd con (CurrentData cmd) +getOneByte :: MonadIO m => CurrentData -> Iso' a C.OneByte -> ConT m a +getOneByte cmd conv = (^. re conv) <$> (oneByte =<< obd) + where obd = Connection.obd (CurrentData cmd) oneByte [x] = return x - oneByte _ = left $ OBDDecodeError NotEnoughBytesError + oneByte _ = throwError $ ConOBDError (OBDDecodeError NotEnoughBytesError) -- | Get two bytes of data and convert it. -getTwoBytes :: CurrentData -> Iso' a C.TwoBytes -> Request a -getTwoBytes cmd conv con = runEitherT $ (^. re conv) <$> (twoBytes =<< obd) - where obd = EitherT $ Connection.obd con (CurrentData cmd) +getTwoBytes :: MonadIO m => CurrentData -> Iso' a C.TwoBytes -> ConT m a +getTwoBytes cmd conv = (^. re conv) <$> (twoBytes =<< obd) + where obd = Connection.obd (CurrentData cmd) twoBytes [x, y] = return (x, y) - twoBytes _ = left $ OBDDecodeError NotEnoughBytesError + twoBytes _ = throwError $ ConOBDError (OBDDecodeError NotEnoughBytesError) diff --git a/src/System/Hardware/ELM327/Simulator.hs b/src/System/Hardware/ELM327/Simulator.hs --- a/src/System/Hardware/ELM327/Simulator.hs +++ b/src/System/Hardware/ELM327/Simulator.hs @@ -83,10 +83,10 @@ is <- makeInputStream (produce c) os <- makeOutputStream (consume c) _ <- forkIO . void $ runStateT (runSimulator c) s - return $ Con is os (atomically $ closeTMChan (_conInputBuffer c)) + return $ Con is os where produce = atomically . readTMChan . _conOutputBuffer - consume _ Nothing = return () + consume c Nothing = atomically $ closeTMChan (_conInputBuffer c) consume c (Just x) = atomically $ writeTMChan (_conInputBuffer c) x runSimulator :: OBDBus bus => SimCon bus -> StateT (Simulator bus) IO () diff --git a/src/System/Hardware/ELM327/Utils/Monad.hs b/src/System/Hardware/ELM327/Utils/Monad.hs --- a/src/System/Hardware/ELM327/Utils/Monad.hs +++ b/src/System/Hardware/ELM327/Utils/Monad.hs @@ -1,6 +1,8 @@ -- | Collection of helper functions to deal with monads. module System.Hardware.ELM327.Utils.Monad where +import Control.Monad.Except (MonadError, throwError) + -- | Convert 'Maybe a' to 'Either a b'. maybeToLeft :: b -> Maybe a -> Either a b maybeToLeft _ (Just x) = Left x @@ -10,3 +12,13 @@ maybeToRight :: b -> Maybe a -> Either b a maybeToRight _ (Just x) = Right x maybeToRight x Nothing = Left x + +-- | Convert 'Maybe a' to @throwError a@. +maybeToExcept :: MonadError e m => Maybe e -> a -> m a +maybeToExcept (Just x) _ = throwError x +maybeToExcept Nothing x = return x + +-- | Throw an exception on 'Nothing'. +orThrow :: MonadError e m => Maybe a -> e -> m a +orThrow Nothing e = throwError e +orThrow (Just x) _ = return x