Basic Binary parser

binary.hs

{-# LANGUAGE RankNTypes #-}

module Binary where

import Prelude hiding (head)

import Control.Applicative
import Control.Monad

import qualified Data.ByteString as B
import Data.Word

data ParseError = EmptyInput
                | PredicateFailure deriving Show

newtype ParserT e m a = ParserT (forall r. B.ByteString -> (a -> B.ByteString -> m r) -> (e -> m r) -> m r)

parse :: ParserT e m a
      -> (a -> B.ByteString -> m r)
      -> (e -> m r)
      -> B.ByteString
      -> m r
parse (ParserT k) s e i = k i s e

instance Functor (ParserT e m) where
  fmap f (ParserT k) = ParserT $ \i s e -> k i (s . f) e

instance Applicative (ParserT e m) where
  pure = return
  (<*>) = ap

instance Monad (ParserT e m) where
  return a = ParserT $ \i s _ -> s a i 

  ParserT k >>= f = ParserT $ \i s e ->  
                      k i (\a i' -> parse (f a) s e i') e

head :: ParserT ParseError m Word8
head = ParserT proc 
  where proc i s e 
          | B.null i  = e EmptyInput
          | otherwise = s (B.head i) (B.tail i)

failed :: e -> ParserT e m a
failed e = ParserT $ \_ _ k -> k e

satisfy :: (Word8 -> Bool) -> ParserT ParseError m Word8
satisfy k = do
  w <- head
  if k w 
    then return w
    else failed PredicateFailure

is :: Word8 -> ParserT ParseError m ()
is w = fmap (const ()) $ satisfy (== w)

string :: [Word8] -> ParserT ParseError m ()
string [] = return ()
string (x:xs) = is x >> string xs

main = do
  line <- B.getLine
  process line
    where parser = string [104, 101, 108, 108, 111] -- hello
          success _ _ = print "True"
          err = print . show
          process i = parse parser success err i