-- | An applicative version of parser. This provides a restricted
-- parser which has only an applicative instance.
module Raaz.Core.Parse.Applicative
       ( Parser, parseWidth, parseError, runParser
       , unsafeRunParser
       , parse, parseStorable
       , parseVector, parseStorableVector
       , unsafeParseVector, unsafeParseStorableVector
       , parseByteString
       , skip
       ) where

import           Data.ByteString           (ByteString)
import           Data.Vector.Generic       (Vector, generateM)
import           Foreign.Ptr               (castPtr)
import           Foreign.Storable          (Storable, peek, peekElemOff)
import           Prelude          hiding   ( length )
import           System.IO.Unsafe          (unsafePerformIO)

import           Raaz.Core.MonoidalAction
import           Raaz.Core.Types.Endian
import           Raaz.Core.Types.Pointer
import           Raaz.Core.Util.ByteString (createFrom, length, withByteString)


type BytesMonoid   = BYTES Int
type ParseAction   = FieldM IO Pointer

-- | An applicative parser type for reading data from a pointer.
type Parser = TwistRF ParseAction BytesMonoid

makeParser :: LengthUnit l => l -> (Pointer -> IO a) -> Parser a
makeParser :: l -> (Pointer -> IO a) -> Parser a
makeParser l
l Pointer -> IO a
action = WrappedArrow (Kleisli IO) Pointer a -> BYTES Int -> Parser a
forall (f :: * -> *) m a. f a -> m -> TwistRF f m a
TwistRF ((Pointer -> IO a) -> WrappedArrow (Kleisli IO) Pointer a
forall a (m :: * -> *) b. (a -> m b) -> FieldM m a b
liftToFieldM Pointer -> IO a
action) (BYTES Int -> Parser a) -> BYTES Int -> Parser a
forall a b. (a -> b) -> a -> b
$ l -> BYTES Int
forall u. LengthUnit u => u -> BYTES Int
inBytes l
l

-- | Skip over some data.
skip :: LengthUnit u => u -> Parser ()
skip :: u -> Parser ()
skip = (u -> (Pointer -> IO ()) -> Parser ())
-> (Pointer -> IO ()) -> u -> Parser ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip u -> (Pointer -> IO ()) -> Parser ()
forall l a. LengthUnit l => l -> (Pointer -> IO a) -> Parser a
makeParser ((Pointer -> IO ()) -> u -> Parser ())
-> (Pointer -> IO ()) -> u -> Parser ()
forall a b. (a -> b) -> a -> b
$ IO () -> Pointer -> IO ()
forall a b. a -> b -> a
const (IO () -> Pointer -> IO ()) -> IO () -> Pointer -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | A parser that fails with a given error message.
parseError  :: String -> Parser a
parseError :: String -> Parser a
parseError String
msg = BYTES Int -> (Pointer -> IO a) -> Parser a
forall l a. LengthUnit l => l -> (Pointer -> IO a) -> Parser a
makeParser (BYTES Int
0 :: BYTES Int) ((Pointer -> IO a) -> Parser a) -> (Pointer -> IO a) -> Parser a
forall a b. (a -> b) -> a -> b
$ \ Pointer
_ -> String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
msg

-- | Return the bytes that this parser will read.
parseWidth :: Parser a -> BYTES Int
parseWidth :: Parser a -> BYTES Int
parseWidth =  Parser a -> BYTES Int
forall (f :: * -> *) m a. TwistRF f m a -> m
twistMonoidValue


-- | Runs a parser on a byte string. It returns `Nothing` if the byte string is smaller than
-- what the parser would consume.
runParser :: Parser a -> ByteString -> Maybe a
runParser :: Parser a -> ByteString -> Maybe a
runParser Parser a
pr ByteString
bs
  | ByteString -> BYTES Int
length ByteString
bs BYTES Int -> BYTES Int -> Bool
forall a. Ord a => a -> a -> Bool
< Parser a -> BYTES Int
forall a. Parser a -> BYTES Int
parseWidth Parser a
pr = Maybe a
forall a. Maybe a
Nothing
  | Bool
otherwise                 = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> a -> Maybe a
forall a b. (a -> b) -> a -> b
$ IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ ByteString -> (Pointer -> IO a) -> IO a
forall a. ByteString -> (Pointer -> IO a) -> IO a
withByteString ByteString
bs ((Pointer -> IO a) -> IO a) -> (Pointer -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ Parser a -> Pointer -> IO a
forall a. Parser a -> Pointer -> IO a
unsafeRunParser Parser a
pr

-- | Run the parser without checking the length constraints.
unsafeRunParser :: Parser a -> Pointer -> IO a
unsafeRunParser :: Parser a -> Pointer -> IO a
unsafeRunParser = FieldM IO Pointer a -> Pointer -> IO a
forall (monad :: * -> *) space b.
FieldM monad space b -> space -> monad b
runFieldM (FieldM IO Pointer a -> Pointer -> IO a)
-> (Parser a -> FieldM IO Pointer a) -> Parser a -> Pointer -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> FieldM IO Pointer a
forall (f :: * -> *) m a. TwistRF f m a -> f a
twistFunctorValue

-- | The primary purpose of this function is to satisfy type checkers.
undefParse :: Parser a -> a
undefParse :: Parser a -> a
undefParse Parser a
_ = a
forall a. HasCallStack => a
undefined

-- | Parses a value which is an instance of Storable. Beware that this
-- parser expects that the value is stored in machine endian. Mostly
-- it is useful in defining the `peek` function in a complicated
-- `Storable` instance.
parseStorable :: Storable a => Parser a
parseStorable :: Parser a
parseStorable = Parser a
pa
  where pa :: Parser a
pa = BYTES Int -> (Pointer -> IO a) -> Parser a
forall l a. LengthUnit l => l -> (Pointer -> IO a) -> Parser a
makeParser (a -> BYTES Int
forall a. Storable a => a -> BYTES Int
sizeOf (a -> BYTES Int) -> a -> BYTES Int
forall a b. (a -> b) -> a -> b
$ Parser a -> a
forall a. Parser a -> a
undefParse Parser a
pa) (Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek (Ptr a -> IO a) -> (Pointer -> Ptr a) -> Pointer -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pointer -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr)

-- | Parse a crypto value. Endian safety is take into account
-- here. This is what you would need when you parse packets from an
-- external source. You can also use this to define the `load`
-- function in a complicated `EndianStore` instance.
parse :: EndianStore a => Parser a
parse :: Parser a
parse = Parser a
pa
  where pa :: Parser a
pa = BYTES Int -> (Pointer -> IO a) -> Parser a
forall l a. LengthUnit l => l -> (Pointer -> IO a) -> Parser a
makeParser (a -> BYTES Int
forall a. Storable a => a -> BYTES Int
sizeOf (a -> BYTES Int) -> a -> BYTES Int
forall a b. (a -> b) -> a -> b
$ Parser a -> a
forall a. Parser a -> a
undefParse Parser a
pa) (Ptr a -> IO a
forall w. EndianStore w => Ptr w -> IO w
load (Ptr a -> IO a) -> (Pointer -> Ptr a) -> Pointer -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pointer -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr)

-- | Parses a strict bytestring of a given length.
parseByteString :: LengthUnit l => l -> Parser ByteString
parseByteString :: l -> Parser ByteString
parseByteString l
l = l -> (Pointer -> IO ByteString) -> Parser ByteString
forall l a. LengthUnit l => l -> (Pointer -> IO a) -> Parser a
makeParser l
l ((Pointer -> IO ByteString) -> Parser ByteString)
-> (Pointer -> IO ByteString) -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ l -> Pointer -> IO ByteString
forall l. LengthUnit l => l -> Pointer -> IO ByteString
createFrom l
l

-- | Similar to @parseStorableVector@ but is expected to be slightly
-- faster. It does not check whether the length parameter is
-- non-negative and hence is unsafe. Use it only if you can prove that
-- the length parameter is non-negative.
unsafeParseStorableVector :: (Storable a, Vector v a) => Int -> Parser (v a)
unsafeParseStorableVector :: Int -> Parser (v a)
unsafeParseStorableVector Int
n = Parser (v a)
pvec
  where pvec :: Parser (v a)
pvec      = BYTES Int -> (Pointer -> IO (v a)) -> Parser (v a)
forall l a. LengthUnit l => l -> (Pointer -> IO a) -> Parser a
makeParser  BYTES Int
width ((Pointer -> IO (v a)) -> Parser (v a))
-> (Pointer -> IO (v a)) -> Parser (v a)
forall a b. (a -> b) -> a -> b
$ \ Pointer
cptr -> Int -> (Int -> IO a) -> IO (v a)
forall (m :: * -> *) (v :: * -> *) a.
(Monad m, Vector v a) =>
Int -> (Int -> m a) -> m (v a)
generateM Int
n (Pointer -> Int -> IO a
forall a. Ptr a -> Int -> IO a
getA Pointer
cptr)
        width :: BYTES Int
width     = Int -> BYTES Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n BYTES Int -> BYTES Int -> BYTES Int
forall a. Num a => a -> a -> a
* a -> BYTES Int
forall a. Storable a => a -> BYTES Int
sizeOf (Parser (v a) -> a
forall a (v :: * -> *).
(Storable a, Vector v a) =>
Parser (v a) -> a
undefA Parser (v a)
pvec)
        undefA    :: (Storable a, Vector v a)=> Parser (v a) -> a
        undefA :: Parser (v a) -> a
undefA Parser (v a)
_  = a
forall a. HasCallStack => a
undefined
        getA :: Ptr a -> Int -> IO a
getA      = Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff (Ptr a -> Int -> IO a) -> (Ptr a -> Ptr a) -> Ptr a -> Int -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr a -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr

-- | Similar to @parseVector@ but is expected to be slightly
-- faster. It does not check whether the length parameter is
-- non-negative and hence is unsafe. Use it only if you can prove that
-- the length parameter is non-negative.
unsafeParseVector :: (EndianStore a, Vector v a) => Int -> Parser (v a)
unsafeParseVector :: Int -> Parser (v a)
unsafeParseVector Int
n = Parser (v a)
pvec
  where pvec :: Parser (v a)
pvec     = BYTES Int -> (Pointer -> IO (v a)) -> Parser (v a)
forall l a. LengthUnit l => l -> (Pointer -> IO a) -> Parser a
makeParser  BYTES Int
width ((Pointer -> IO (v a)) -> Parser (v a))
-> (Pointer -> IO (v a)) -> Parser (v a)
forall a b. (a -> b) -> a -> b
$ \ Pointer
cptr -> Int -> (Int -> IO a) -> IO (v a)
forall (m :: * -> *) (v :: * -> *) a.
(Monad m, Vector v a) =>
Int -> (Int -> m a) -> m (v a)
generateM Int
n (Ptr a -> Int -> IO a
forall w. EndianStore w => Ptr w -> Int -> IO w
loadFromIndex (Pointer -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Pointer
cptr))
        width :: BYTES Int
width    = Int -> BYTES Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n BYTES Int -> BYTES Int -> BYTES Int
forall a. Num a => a -> a -> a
* a -> BYTES Int
forall a. Storable a => a -> BYTES Int
sizeOf (Parser (v a) -> a
forall a (v :: * -> *).
(EndianStore a, Vector v a) =>
Parser (v a) -> a
undefA Parser (v a)
pvec)
        undefA   :: (EndianStore a, Vector v a)=> Parser (v a) -> a
        undefA :: Parser (v a) -> a
undefA Parser (v a)
_ = a
forall a. HasCallStack => a
undefined

-- | Similar to `parseVector` but parses according to the host
-- endian. This function is essentially used to define storable
-- instances of complicated data. It is unlikely to be of use when
-- parsing externally serialised data as one would want to keep track
-- of the endianness of the data.
parseStorableVector :: (Storable a, Vector v a) => Int -> Parser (v a)
parseStorableVector :: Int -> Parser (v a)
parseStorableVector Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0      = String -> Parser (v a)
forall a. String -> Parser a
parseError (String -> Parser (v a)) -> String -> Parser (v a)
forall a b. (a -> b) -> a -> b
$ String
"parseStorableVector on " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
                      | Bool
otherwise  = Int -> Parser (v a)
forall a (v :: * -> *).
(Storable a, Vector v a) =>
Int -> Parser (v a)
unsafeParseStorableVector Int
n

-- | Parses a vector of elements. It takes care of the correct endian
-- conversion. This is the function to use while parsing external
-- data.
parseVector :: (EndianStore a, Vector v a) => Int -> Parser (v a)
parseVector :: Int -> Parser (v a)
parseVector Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0      = String -> Parser (v a)
forall a. String -> Parser a
parseError (String -> Parser (v a)) -> String -> Parser (v a)
forall a b. (a -> b) -> a -> b
$ String
"parseVector on " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
              | Bool
otherwise  = Int -> Parser (v a)
forall a (v :: * -> *).
(EndianStore a, Vector v a) =>
Int -> Parser (v a)
unsafeParseVector Int
n