Parser.hs

{-# LANGUAGE OverloadedStrings #-}
module Parser where
import           Control.Monad           as M
import           Data.Binary             (Word8)
import           Data.Binary.Builder     (toLazyByteString)
import qualified Data.Binary.Builder     as B
import qualified Data.ByteString.Builder as BL
import qualified Data.ByteString.Lazy    as L
import           Data.Text               (Text)


newtype Parser a = Parser { runParser :: L.ByteString -> Either String (L.ByteString, a) }

instance Functor Parser where
    fmap f (Parser pFunc) = Parser (\s ->
        let result = pFunc s
        in (fmap . fmap) f result
        )

instance Applicative Parser where
    pure x = Parser (\s -> pure (L.empty, x))
    (Parser pFuncA) <*> (Parser pFuncB) = Parser (\s ->
        do
            (rest, f) <- pFuncA s
            (rest', x) <- pFuncB rest
            return (rest', f x)
        )

instance Monad Parser where
    return = pure
    (Parser pFunc) >>= f = Parser (\s ->
        case pFunc s of
            Left txt        -> Left txt
            Right (rest, a) -> (runParser $ f a) rest
        )

instance MonadFail Parser where
    fail s = Parser (const $ Left s)


byte :: Word8 -> Parser Word8
byte byte = Parser (\s ->
    case L.uncons s of
        Nothing -> Left "Unexpected end of input"
        Just (byte', rest) ->
            if byte' == byte
            then Right (rest, byte')
            else Left ("Unexpected byte: " <> show byte' <> " - expected: " <> show byte)
        )

chunk :: L.ByteString -> Parser L.ByteString
chunk chunk = Parser (\s -> do
    let length' = L.length chunk

    if L.length s < length'
    then Left "Unexpected end of input"
    else
        if L.take length' s == chunk
        then Right (L.drop (L.length chunk) s, L.take length' s)
        else Left ("Unexpected chunk: " <> show (L.take length' s) <> " - expected: " <> show chunk)

    )


one :: Parser Word8
one = Parser (\s ->
    case L.uncons s of
        Nothing           -> Left "Unexpected end of input"
        Just (head, tail) -> Right (tail, head)
    )

repeatN :: Parser a -> Int -> Parser [a]
repeatN parser n = go n
    where
        go 0 = pure []
        go n = do
           x <- parser
           xs <- go (n - 1)
           return (x : xs)

takeN :: Int -> Parser [Word8]
takeN = repeatN one

takeN' :: Int -> Parser L.ByteString
takeN' n = do
   res <- repeatN one n
   return $ toLazyByteString $ mconcat $ fmap BL.word8Hex res