{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

module Network.SLCAN.Parser
  ( parseSLCANMessage
  ) where

import Data.Attoparsec.ByteString.Char8 (Parser)
import Data.Bits (Bits)
import Data.ByteString (ByteString)
import Data.Set (Set)
import Control.Applicative ((<|>))
import Network.CAN.Types (CANArbitrationField(..), CANMessage(..))
import Network.SLCAN.Types
  ( SLCANMessage(..)
  , SLCANControl(..)
  , SLCANBitrate
  , SLCANState(..)
  , SLCANCounters(..)
  , SLCANError(..)
  )

import qualified Data.Attoparsec.ByteString.Char8
import qualified Data.Set
import qualified Control.Monad

slCANParser :: Parser SLCANMessage
slCANParser :: Parser SLCANMessage
slCANParser = do
  Parser Char
Data.Attoparsec.ByteString.Char8.peekChar'
    Parser Char -> (Char -> Parser SLCANMessage) -> Parser SLCANMessage
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Char
c | String -> Char -> Bool
Data.Attoparsec.ByteString.Char8.inClass String
"OCSFL" Char
c ->
        (SLCANControl -> SLCANMessage
SLCANMessage_Control (SLCANControl -> SLCANMessage)
-> Parser ByteString SLCANControl -> Parser SLCANMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString SLCANControl
slCANControlParser)
      Char
c | String -> Char -> Bool
Data.Attoparsec.ByteString.Char8.inClass String
"tTrR" Char
c ->
        (CANMessage -> SLCANMessage
SLCANMessage_Data (CANMessage -> SLCANMessage)
-> Parser ByteString CANMessage -> Parser SLCANMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString CANMessage
slCANDataParser)
      Char
's' ->
        Char -> Parser Char
Data.Attoparsec.ByteString.Char8.char Char
's'
        Parser Char -> Parser SLCANMessage -> Parser SLCANMessage
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (SLCANState -> SLCANCounters -> SLCANMessage
SLCANMessage_State (SLCANState -> SLCANCounters -> SLCANMessage)
-> Parser ByteString SLCANState
-> Parser ByteString (SLCANCounters -> SLCANMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString SLCANState
slCANStateParser Parser ByteString (SLCANCounters -> SLCANMessage)
-> Parser ByteString SLCANCounters -> Parser SLCANMessage
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString SLCANCounters
slCANCountersParser)
      Char
'e' ->
        Char -> Parser Char
Data.Attoparsec.ByteString.Char8.char Char
'e'
        Parser Char -> Parser SLCANMessage -> Parser SLCANMessage
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Set SLCANError -> SLCANMessage
SLCANMessage_Error (Set SLCANError -> SLCANMessage)
-> Parser ByteString (Set SLCANError) -> Parser SLCANMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (Set SLCANError)
slCANErrorParser)
      Char
c | Bool
otherwise ->
        String -> Parser SLCANMessage
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser SLCANMessage) -> String -> Parser SLCANMessage
forall a b. (a -> b) -> a -> b
$ String
"Unknown SLCAN message type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Char -> String
forall a. Show a => a -> String
show Char
c
  Parser SLCANMessage -> Parser Char -> Parser SLCANMessage
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser Char
Data.Attoparsec.ByteString.Char8.char Char
'\r'

slCANControlParser :: Parser SLCANControl
slCANControlParser :: Parser ByteString SLCANControl
slCANControlParser = do
  Parser Char
Data.Attoparsec.ByteString.Char8.anyChar
  Parser Char
-> (Char -> Parser ByteString SLCANControl)
-> Parser ByteString SLCANControl
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Char
'O' -> SLCANControl -> Parser ByteString SLCANControl
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SLCANControl
SLCANControl_Open
    Char
'C' -> SLCANControl -> Parser ByteString SLCANControl
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SLCANControl
SLCANControl_Close
    Char
'S' -> (SLCANBitrate -> SLCANControl
SLCANControl_Bitrate (SLCANBitrate -> SLCANControl)
-> Parser ByteString SLCANBitrate -> Parser ByteString SLCANControl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString SLCANBitrate
bitrate)
    Char
'F' -> SLCANControl -> Parser ByteString SLCANControl
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SLCANControl
SLCANControl_ResetErrors
    Char
'L' -> SLCANControl -> Parser ByteString SLCANControl
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SLCANControl
SLCANControl_ListenOnly
    Char
c   -> String -> Parser ByteString SLCANControl
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ByteString SLCANControl)
-> String -> Parser ByteString SLCANControl
forall a b. (a -> b) -> a -> b
$ String
"Unknown control message char: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Char -> String
forall a. Show a => a -> String
show Char
c
  where
    bitrate :: Parser ByteString SLCANBitrate
bitrate = do
      Int
d <- Parser Int
forall a. Integral a => Parser a
Data.Attoparsec.ByteString.Char8.decimal
      if Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> SLCANBitrate -> Int
forall a. Enum a => a -> Int
fromEnum (SLCANBitrate
forall a. Bounded a => a
maxBound :: SLCANBitrate)
      then String -> Parser ByteString SLCANBitrate
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
             (String -> Parser ByteString SLCANBitrate)
-> String -> Parser ByteString SLCANBitrate
forall a b. (a -> b) -> a -> b
$ String
"Bitrate out of bounds, got "
             String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
d
             String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"but maximum is "
             String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (SLCANBitrate -> Int
forall a. Enum a => a -> Int
fromEnum (SLCANBitrate
forall a. Bounded a => a
maxBound :: SLCANBitrate))
             String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" ("
             String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SLCANBitrate -> String
forall a. Show a => a -> String
show  (SLCANBitrate
forall a. Bounded a => a
maxBound :: SLCANBitrate)
             String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
      else SLCANBitrate -> Parser ByteString SLCANBitrate
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SLCANBitrate -> Parser ByteString SLCANBitrate)
-> SLCANBitrate -> Parser ByteString SLCANBitrate
forall a b. (a -> b) -> a -> b
$ Int -> SLCANBitrate
forall a. Enum a => Int -> a
toEnum Int
d

slCANDataParser :: Parser CANMessage
slCANDataParser :: Parser ByteString CANMessage
slCANDataParser = do
  CANArbitrationField
canMessageArbitrationField <- Parser CANArbitrationField
arbitrationId
  Int
msgLen <- Int -> Parser Int
forall a. (Bits a, Integral a) => Int -> Parser a
hexadecimalWithLength Int
1
  [Word8]
canMessageData <-
    Int -> Parser ByteString Word8 -> Parser ByteString [Word8]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
Control.Monad.replicateM Int
msgLen (Int -> Parser ByteString Word8
forall a. (Bits a, Integral a) => Int -> Parser a
hexadecimalWithLength Int
2)
  CANMessage -> Parser ByteString CANMessage
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CANMessage{[Word8]
CANArbitrationField
canMessageArbitrationField :: CANArbitrationField
canMessageData :: [Word8]
canMessageData :: [Word8]
canMessageArbitrationField :: CANArbitrationField
..}

-- | Parse arbitration ID
-- * t => 11 bit data frame
-- * r => 11 bit RTR frame
-- * T => 29 bit data frame
-- * R => 29 bit RTR frame
arbitrationId :: Parser CANArbitrationField
arbitrationId :: Parser CANArbitrationField
arbitrationId = do
      Char -> Parser Char
Data.Attoparsec.ByteString.Char8.char Char
't' Parser Char
-> Parser CANArbitrationField -> Parser CANArbitrationField
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> Parser CANArbitrationField
stdID Bool
False
  Parser CANArbitrationField
-> Parser CANArbitrationField -> Parser CANArbitrationField
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
Data.Attoparsec.ByteString.Char8.char Char
'r' Parser Char
-> Parser CANArbitrationField -> Parser CANArbitrationField
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> Parser CANArbitrationField
stdID Bool
True
  Parser CANArbitrationField
-> Parser CANArbitrationField -> Parser CANArbitrationField
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
Data.Attoparsec.ByteString.Char8.char Char
'T' Parser Char
-> Parser CANArbitrationField -> Parser CANArbitrationField
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> Parser CANArbitrationField
extID Bool
False
  Parser CANArbitrationField
-> Parser CANArbitrationField -> Parser CANArbitrationField
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Char
Data.Attoparsec.ByteString.Char8.char Char
'R' Parser Char
-> Parser CANArbitrationField -> Parser CANArbitrationField
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> Parser CANArbitrationField
extID Bool
True

stdID
  :: Bool
  -> Parser CANArbitrationField
stdID :: Bool -> Parser CANArbitrationField
stdID Bool
isRTR = do
  Word32
canArbitrationFieldID
    <- Int -> Parser Word32
forall a. (Bits a, Integral a) => Int -> Parser a
hexadecimalWithLength Int
3

  let
    canArbitrationFieldExtended :: Bool
canArbitrationFieldExtended = Bool
False
    canArbitrationFieldRTR :: Bool
canArbitrationFieldRTR = Bool
isRTR

  CANArbitrationField -> Parser CANArbitrationField
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CANArbitrationField{Bool
Word32
canArbitrationFieldID :: Word32
canArbitrationFieldExtended :: Bool
canArbitrationFieldRTR :: Bool
canArbitrationFieldRTR :: Bool
canArbitrationFieldExtended :: Bool
canArbitrationFieldID :: Word32
..}

extID
  :: Bool
  -> Parser CANArbitrationField
extID :: Bool -> Parser CANArbitrationField
extID Bool
isRTR = do
  Word32
canArbitrationFieldID
    <- Int -> Parser Word32
forall a. (Bits a, Integral a) => Int -> Parser a
hexadecimalWithLength Int
8

  let
    canArbitrationFieldExtended :: Bool
canArbitrationFieldExtended = Bool
True
    canArbitrationFieldRTR :: Bool
canArbitrationFieldRTR = Bool
isRTR

  CANArbitrationField -> Parser CANArbitrationField
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CANArbitrationField{Bool
Word32
canArbitrationFieldRTR :: Bool
canArbitrationFieldExtended :: Bool
canArbitrationFieldID :: Word32
canArbitrationFieldID :: Word32
canArbitrationFieldExtended :: Bool
canArbitrationFieldRTR :: Bool
..}

hexadecimalWithLength
  :: ( Bits a
     , Integral a
     )
  => Int
  -> Parser a
hexadecimalWithLength :: forall a. (Bits a, Integral a) => Int -> Parser a
hexadecimalWithLength Int
len =
  Int -> Parser ByteString
Data.Attoparsec.ByteString.Char8.take Int
len
  Parser ByteString
-> (ByteString -> Parser ByteString a) -> Parser ByteString a
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  (String -> Parser ByteString a)
-> (a -> Parser ByteString a)
-> Either String a
-> Parser ByteString a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    String -> Parser ByteString a
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
    a -> Parser ByteString a
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Either String a -> Parser ByteString a)
-> (ByteString -> Either String a)
-> ByteString
-> Parser ByteString a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser ByteString a -> ByteString -> Either String a
forall a. Parser a -> ByteString -> Either String a
Data.Attoparsec.ByteString.Char8.parseOnly
        Parser ByteString a
forall a. (Integral a, Bits a) => Parser a
Data.Attoparsec.ByteString.Char8.hexadecimal

slCANStateParser :: Parser SLCANState
slCANStateParser :: Parser ByteString SLCANState
slCANStateParser =
  Parser Char
Data.Attoparsec.ByteString.Char8.anyChar
  Parser Char
-> (Char -> Parser ByteString SLCANState)
-> Parser ByteString SLCANState
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Char
'a' -> SLCANState -> Parser ByteString SLCANState
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SLCANState
SLCANState_Active
    Char
'w' -> SLCANState -> Parser ByteString SLCANState
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SLCANState
SLCANState_Warning
    Char
'p' -> SLCANState -> Parser ByteString SLCANState
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SLCANState
SLCANState_Passive
    Char
'b' -> SLCANState -> Parser ByteString SLCANState
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SLCANState
SLCANState_BusOff
    Char
c   -> String -> Parser ByteString SLCANState
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ByteString SLCANState)
-> String -> Parser ByteString SLCANState
forall a b. (a -> b) -> a -> b
$ String
"Unknown state char: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Char -> String
forall a. Show a => a -> String
show Char
c

slCANCountersParser :: Parser SLCANCounters
slCANCountersParser :: Parser ByteString SLCANCounters
slCANCountersParser = do
    Word16
slCANCountersTxErrors <- Parser ByteString Word16
decimal3
    Word16
slCANCountersRxErrors <- Parser ByteString Word16
decimal3
    SLCANCounters -> Parser ByteString SLCANCounters
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SLCANCounters -> Parser ByteString SLCANCounters)
-> SLCANCounters -> Parser ByteString SLCANCounters
forall a b. (a -> b) -> a -> b
$ SLCANCounters{Word16
slCANCountersTxErrors :: Word16
slCANCountersRxErrors :: Word16
slCANCountersTxErrors :: Word16
slCANCountersRxErrors :: Word16
..}
  where
    decimal3 :: Parser ByteString Word16
decimal3 =
      Int -> Parser ByteString
Data.Attoparsec.ByteString.Char8.take Int
3
      Parser ByteString
-> (ByteString -> Parser ByteString Word16)
-> Parser ByteString Word16
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      (String -> Parser ByteString Word16)
-> (Word16 -> Parser ByteString Word16)
-> Either String Word16
-> Parser ByteString Word16
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
        String -> Parser ByteString Word16
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
        Word16 -> Parser ByteString Word16
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Either String Word16 -> Parser ByteString Word16)
-> (ByteString -> Either String Word16)
-> ByteString
-> Parser ByteString Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser ByteString Word16 -> ByteString -> Either String Word16
forall a. Parser a -> ByteString -> Either String a
Data.Attoparsec.ByteString.Char8.parseOnly
            Parser ByteString Word16
forall a. Integral a => Parser a
Data.Attoparsec.ByteString.Char8.decimal

slCANErrorParser :: Parser (Set SLCANError)
slCANErrorParser :: Parser ByteString (Set SLCANError)
slCANErrorParser = do
  Int
len <- Int -> Parser Int
forall a. (Bits a, Integral a) => Int -> Parser a
hexadecimalWithLength Int
1
  [SLCANError] -> Set SLCANError
forall a. Ord a => [a] -> Set a
Data.Set.fromList
    ([SLCANError] -> Set SLCANError)
-> Parser ByteString [SLCANError]
-> Parser ByteString (Set SLCANError)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Parser ByteString SLCANError -> Parser ByteString [SLCANError]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
Control.Monad.replicateM Int
len Parser ByteString SLCANError
errorChar
  where
    errorChar :: Parser ByteString SLCANError
errorChar =
      Parser Char
Data.Attoparsec.ByteString.Char8.anyChar
      Parser Char
-> (Char -> Parser ByteString SLCANError)
-> Parser ByteString SLCANError
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Char
'a' -> SLCANError -> Parser ByteString SLCANError
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SLCANError
SLCANError_Ack
        Char
'b' -> SLCANError -> Parser ByteString SLCANError
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SLCANError
SLCANError_Bit0
        Char
'B' -> SLCANError -> Parser ByteString SLCANError
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SLCANError
SLCANError_Bit1
        Char
'c' -> SLCANError -> Parser ByteString SLCANError
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SLCANError
SLCANError_CRC
        Char
'f' -> SLCANError -> Parser ByteString SLCANError
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SLCANError
SLCANError_Form
        Char
'o' -> SLCANError -> Parser ByteString SLCANError
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SLCANError
SLCANError_RxOverrun
        Char
'O' -> SLCANError -> Parser ByteString SLCANError
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SLCANError
SLCANError_TxOverrun
        Char
's' -> SLCANError -> Parser ByteString SLCANError
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SLCANError
SLCANError_Stuff
        Char
c   -> String -> Parser ByteString SLCANError
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ByteString SLCANError)
-> String -> Parser ByteString SLCANError
forall a b. (a -> b) -> a -> b
$ String
"Unknown error char: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Char -> String
forall a. Show a => a -> String
show Char
c

parseSLCANMessage
  :: ByteString
  -> Either String SLCANMessage
parseSLCANMessage :: ByteString -> Either String SLCANMessage
parseSLCANMessage =
  Parser SLCANMessage -> ByteString -> Either String SLCANMessage
forall a. Parser a -> ByteString -> Either String a
Data.Attoparsec.ByteString.Char8.parseOnly
    Parser SLCANMessage
slCANParser