Parser.hs

-- |
-- Module      : Streamly.Internal.Data.Binary.Parser
-- Copyright   : (c) 2020 Composewell Technologies
-- License     : BSD-3-Clause
-- Maintainer  : streamly@composewell.com
-- Portability : GHC
--
-- Decode Haskell data types from byte streams.
--
-- It would be inefficient to use this to compose parsers for general algebraic
-- data types. For general deserialization of ADTs please use the Serialize
-- type class instances. The fastest way to deserialize byte streams
-- representing Haskell data types is to write them to arrays and deserialize
-- the array using the Serialize type class.

module Streamly.Internal.Data.Binary.Parser
    (
    -- * Type class
      FromBytes (..)

    -- * Decoders
    , unit
    , bool
    , ordering
    , eqWord8 -- XXX rename to word8Eq
    , word8
    , word16be
    , word16le
    , word32be
    , word32le
    , word64be
    , word64le
    , word64host
    , int8
    , int16be
    , int16le
    , int32be
    , int32le
    , int64be
    , int64le
    , float32be
    , float32le
    , double64be
    , double64le
    , charLatin1
    )
where

import Control.Monad.IO.Class (MonadIO)
import Data.Bits ((.|.), unsafeShiftL)
import Data.Char (chr)
import Data.Int (Int8, Int16, Int32, Int64)
import GHC.Float (castWord32ToFloat, castWord64ToDouble)
import Data.Word (Word8, Word16, Word32, Word64)
import Streamly.Internal.Data.Parser (Parser)
import Streamly.Internal.Data.Maybe.Strict (Maybe'(..))
import Streamly.Internal.Data.Tuple.Strict (Tuple' (..))
import qualified Streamly.Data.Array as A
import qualified Streamly.Internal.Data.Array as A
    (unsafeGetIndex, unsafeCast)
import qualified Streamly.Internal.Data.Parser as PR
    (fromPure, either, satisfy, takeEQ)
import qualified Streamly.Internal.Data.Parser as PRD
    (Parser(..), Initial(..), Step(..), Final(..))

-- Note: The () type does not need to have an on-disk representation in theory.
-- But we use a concrete representation for it so that we count how many ()
-- types we have. Or when we have an array of units the array a concrete
-- length.

-- | A value of type '()' is encoded as @0@ in binary encoding.
--
-- @
-- 0 ==> ()
-- @
--
-- /Pre-release/
--
{-# INLINE unit #-}
unit :: Monad m => Parser Word8 m ()
unit = eqWord8 0 *> PR.fromPure ()

{-# INLINE word8ToBool #-}
word8ToBool :: Word8 -> Either String Bool
word8ToBool 0 = Right False
word8ToBool 1 = Right True
word8ToBool w = Left ("Invalid Bool encoding " ++ Prelude.show w)

-- | A value of type 'Bool' is encoded as follows in binary encoding.
--
-- @
-- 0 ==> False
-- 1 ==> True
-- @
--
-- /Pre-release/
--
{-# INLINE bool #-}
bool :: Monad m => Parser Word8 m Bool
bool = PR.either word8ToBool

{-# INLINE word8ToOrdering #-}
word8ToOrdering :: Word8 -> Either String Ordering
word8ToOrdering 0 = Right LT
word8ToOrdering 1 = Right EQ
word8ToOrdering 2 = Right GT
word8ToOrdering w = Left ("Invalid Ordering encoding " ++ Prelude.show w)

-- | A value of type 'Ordering' is encoded as follows in binary encoding.
--
-- @
-- 0 ==> LT
-- 1 ==> EQ
-- 2 ==> GT
-- @
--
-- /Pre-release/
--
{-# INLINE ordering #-}
ordering :: Monad m => Parser Word8 m Ordering
ordering = PR.either word8ToOrdering

-- XXX should go in a Word8 parser module?
-- | Accept the input byte only if it is equal to the specified value.
--
-- /Pre-release/
--
{-# INLINE eqWord8 #-}
eqWord8 :: Monad m => Word8 -> Parser Word8 m Word8
eqWord8 b = PR.satisfy (== b)

-- | Accept any byte.
--
-- /Pre-release/
--
{-# INLINE word8 #-}
word8 :: Monad m => Parser Word8 m Word8
word8 = PR.satisfy (const True)

-- | Big endian (MSB first) Word16
{-# INLINE word16beD #-}
word16beD :: Monad m => PRD.Parser Word8 m Word16
word16beD = PRD.Parser step initial extract

    where

    initial = return $ PRD.IPartial Nothing'

    step Nothing' a =
        -- XXX We can use a non-failing parser or a fold so that we do not
        -- have to buffer for backtracking which is inefficient.
        return $ PRD.SContinue 1 (Just' (fromIntegral a `unsafeShiftL` 8))
    step (Just' w) a =
        return $ PRD.SDone 1 (w .|. fromIntegral a)

    extract _ = return $ PRD.FError "word16be: end of input"

-- | Parse two bytes as a 'Word16', the first byte is the MSB of the Word16 and
-- second byte is the LSB (big endian representation).
--
-- /Pre-release/
--
{-# INLINE word16be #-}
word16be :: Monad m => Parser Word8 m Word16
word16be = word16beD

-- | Little endian (LSB first) Word16
{-# INLINE word16leD #-}
word16leD :: Monad m => PRD.Parser Word8 m Word16
word16leD = PRD.Parser step initial extract

    where

    initial = return $ PRD.IPartial Nothing'

    step Nothing' a =
        return $ PRD.SContinue 1 (Just' (fromIntegral a))
    step (Just' w) a =
        return $ PRD.SDone 1 (w .|. fromIntegral a `unsafeShiftL` 8)

    extract _ = return $ PRD.FError "word16le: end of input"

-- | Parse two bytes as a 'Word16', the first byte is the LSB of the Word16 and
-- second byte is the MSB (little endian representation).
--
-- /Pre-release/
--
{-# INLINE word16le #-}
word16le :: Monad m => Parser Word8 m Word16
word16le = word16leD

-- | Big endian (MSB first) Word32
{-# INLINE word32beD #-}
word32beD :: Monad m => PRD.Parser Word8 m Word32
word32beD = PRD.Parser step initial extract

    where

    initial = return $ PRD.IPartial $ Tuple' 0 24

    step (Tuple' w sh) a = return $
        if sh /= 0
        then
            let w1 = w .|. (fromIntegral a `unsafeShiftL` sh)
             in PRD.SContinue 1 (Tuple' w1 (sh - 8))
        else PRD.SDone 1 (w .|. fromIntegral a)

    extract _ = return $ PRD.FError "word32beD: end of input"

-- | Parse four bytes as a 'Word32', the first byte is the MSB of the Word32
-- and last byte is the LSB (big endian representation).
--
-- /Pre-release/
--
{-# INLINE word32be #-}
word32be :: Monad m => Parser Word8 m Word32
word32be = word32beD

-- | Little endian (LSB first) Word32
{-# INLINE word32leD #-}
word32leD :: Monad m => PRD.Parser Word8 m Word32
word32leD = PRD.Parser step initial extract

    where

    initial = return $ PRD.IPartial $ Tuple' 0 0

    step (Tuple' w sh) a = return $
        let w1 = w .|. (fromIntegral a `unsafeShiftL` sh)
         in if sh /= 24
            then PRD.SContinue 1 (Tuple' w1 (sh + 8))
            else PRD.SDone 1 w1

    extract _ = return $ PRD.FError "word32leD: end of input"

-- | Parse four bytes as a 'Word32', the first byte is the MSB of the Word32
-- and last byte is the LSB (big endian representation).
--
-- /Pre-release/
--
{-# INLINE word32le #-}
word32le :: Monad m => Parser Word8 m Word32
word32le = word32leD

-- | Big endian (MSB first) Word64
{-# INLINE word64beD #-}
word64beD :: Monad m => PRD.Parser Word8 m Word64
word64beD = PRD.Parser step initial extract

    where

    initial = return $ PRD.IPartial $ Tuple' 0 56

    step (Tuple' w sh) a = return $
        if sh /= 0
        then
            let w1 = w .|. (fromIntegral a `unsafeShiftL` sh)
             in PRD.SContinue 1 (Tuple' w1 (sh - 8))
        else PRD.SDone 1 (w .|. fromIntegral a)

    extract _ = return $ PRD.FError "word64beD: end of input"

-- | Parse eight bytes as a 'Word64', the first byte is the MSB of the Word64
-- and last byte is the LSB (big endian representation).
--
-- /Pre-release/
--
{-# INLINE word64be #-}
word64be :: Monad m => Parser Word8 m Word64
word64be = word64beD

-- | Little endian (LSB first) Word64
{-# INLINE word64leD #-}
word64leD :: Monad m => PRD.Parser Word8 m Word64
word64leD = PRD.Parser step initial extract

    where

    initial = return $ PRD.IPartial $ Tuple' 0 0

    step (Tuple' w sh) a = return $
        let w1 = w .|. (fromIntegral a `unsafeShiftL` sh)
         in if sh /= 56
            then PRD.SContinue 1 (Tuple' w1 (sh + 8))
            else PRD.SDone 1 w1

    extract _ = return $ PRD.FError "word64leD: end of input"

-- | Parse eight bytes as a 'Word64', the first byte is the MSB of the Word64
-- and last byte is the LSB (big endian representation).
--
-- /Pre-release/
--
{-# INLINE word64le #-}
word64le :: Monad m => Parser Word8 m Word64
word64le = word64leD

{-# INLINE int8 #-}
int8 :: Monad m => Parser Word8 m Int8
int8 = fromIntegral <$> word8

-- | Parse two bytes as a 'Int16', the first byte is the MSB of the Int16 and
-- second byte is the LSB (big endian representation).
--
-- /Pre-release/
--
{-# INLINE int16be #-}
int16be :: Monad m => Parser Word8 m Int16
int16be = fromIntegral <$> word16be

-- | Parse two bytes as a 'Int16', the first byte is the LSB of the Int16 and
-- second byte is the MSB (little endian representation).
--
-- /Pre-release/
--
{-# INLINE int16le #-}
int16le :: Monad m => Parser Word8 m Int16
int16le = fromIntegral <$> word16le

-- | Parse four bytes as a 'Int32', the first byte is the MSB of the Int32
-- and last byte is the LSB (big endian representation).
--
-- /Pre-release/
--
{-# INLINE int32be #-}
int32be :: Monad m => Parser Word8 m Int32
int32be = fromIntegral <$> word32be

-- | Parse four bytes as a 'Int32', the first byte is the MSB of the Int32
-- and last byte is the LSB (big endian representation).
--
-- /Pre-release/
--
{-# INLINE int32le #-}
int32le :: Monad m => Parser Word8 m Int32
int32le = fromIntegral <$> word32le

-- | Parse eight bytes as a 'Int64', the first byte is the MSB of the Int64
-- and last byte is the LSB (big endian representation).
--
-- /Pre-release/
--
{-# INLINE int64be #-}
int64be :: Monad m => Parser Word8 m Int64
int64be = fromIntegral <$> word64be

-- | Parse eight bytes as a 'Int64', the first byte is the MSB of the Int64
-- and last byte is the LSB (big endian representation).
--
-- /Pre-release/
--
{-# INLINE int64le #-}
int64le :: Monad m => Parser Word8 m Int64
int64le = fromIntegral <$> word64le

{-# INLINE float32be #-}
float32be :: MonadIO m => Parser Word8 m Float
float32be = castWord32ToFloat <$> word32be

{-# INLINE float32le #-}
float32le :: MonadIO m => Parser Word8 m Float
float32le = castWord32ToFloat <$> word32le

{-# INLINE double64be #-}
double64be :: MonadIO m => Parser Word8 m Double
double64be =  castWord64ToDouble <$> word64be

{-# INLINE double64le #-}
double64le :: MonadIO m => Parser Word8 m Double
double64le = castWord64ToDouble <$> word64le

-- | Accept any byte.
--
-- /Pre-release/
--
{-# INLINE charLatin1 #-}
charLatin1 :: Monad m => Parser Word8 m Char
charLatin1 = fmap (chr . fromIntegral) word8

-------------------------------------------------------------------------------
-- Host byte order
-------------------------------------------------------------------------------

-- | Parse eight bytes as a 'Word64' in the host byte order.
--
-- /Pre-release/
--
{-# INLINE word64host #-}
word64host :: MonadIO m => Parser Word8 m Word64
word64host =
    fmap (A.unsafeGetIndex 0 . A.unsafeCast) $ PR.takeEQ 8 (A.createOf 8)

-------------------------------------------------------------------------------
-- Type class
-------------------------------------------------------------------------------

class FromBytes a where
    -- | Decode a byte stream to a Haskell type.
    fromBytes :: Parser Word8 m a