Hufflepdf/src/PDF/Parser.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE UndecidableInstances #-}
module PDF.Parser (
      MonadParser(..)
    , Parser
    , (<?>)
    , octDigit
    , on
    , runParser
    , evalParser
  ) where

import Control.Applicative (Alternative, (<|>))
import Control.Monad (MonadPlus)
import Control.Monad.Fail (MonadFail(..))
import Control.Monad.State (StateT(..), evalStateT)
import Control.Monad.Trans (MonadTrans(..))
import qualified Data.Attoparsec.ByteString.Char8 as Atto (
      Parser, char, endOfInput, parseOnly, peekChar', satisfy, string, take
    , takeWhile, takeWhile1
  )
import Data.ByteString (ByteString)
import Data.ByteString.Char8.Util (B16Int(..))
import Data.Char (toLower)
import Data.Set (Set)
import qualified Data.Set as Set (fromList, member, unions)
import Prelude hiding (fail)

type MonadDeps m = (MonadFail m, MonadPlus m)

class MonadDeps m => MonadParser m where
  block :: Int -> m ByteString
  char :: Char -> m Char
  decNumber :: m ByteString
  endOfInput :: m ()
  hexNumber :: m B16Int
  oneOf :: String -> m Char
  peek :: m Char
  string :: ByteString -> m ByteString
  takeAll :: (Char -> Bool) -> m ByteString
  takeAll1 :: (Char -> Bool) -> m ByteString

instance MonadParser Atto.Parser where
  block = Atto.take
  char = Atto.char
  endOfInput = Atto.endOfInput
  decNumber = Atto.takeWhile1 (`Set.member` digits)
  hexNumber = B16Int <$> Atto.takeWhile1 (`Set.member` hexDigits)
  oneOf charSet = Atto.satisfy (`elem` charSet)
  peek = Atto.peekChar'
  string s = Atto.string s <?> show s
  takeAll = Atto.takeWhile
  takeAll1 = Atto.takeWhile1

instance (MonadParser m, MonadTrans t, MonadDeps (t m)) => MonadParser (t m) where
  block = lift . block
  char = lift . char
  endOfInput = lift $ endOfInput
  decNumber = lift $ decNumber
  hexNumber = lift $ hexNumber
  oneOf = lift . oneOf
  peek = lift $ peek
  string = lift . string
  takeAll = lift . takeAll
  takeAll1 = lift . takeAll1

type Parser s = StateT s Atto.Parser

(<?>) :: (Alternative m, MonadFail m) => m a -> String -> m a
(<?>) parser debugMessage = parser <|> fail debugMessage

digits :: Set Char
digits = Set.fromList ['0'..'9']

hexDigits :: Set Char
hexDigits = Set.unions [digits, Set.fromList af, Set.fromList $ toLower <$> af]
  where
    af = ['A'..'F']

octDigit :: MonadParser m => m Char
octDigit = oneOf ['0'..'7']

on :: Parser s a -> ByteString -> Parser s (Either String a)
on (StateT parserF) input = StateT $ \state ->
  case Atto.parseOnly (parserF state) input of
    Left errorMsg -> return (Left errorMsg, state)
    Right (result, newState) -> return (Right result, newState)

runParser :: Parser s a -> s -> ByteString -> Either String (a, s)
runParser parser initState = Atto.parseOnly (runStateT parser initState)

evalParser :: Parser s a -> s -> ByteString -> Either String a
evalParser parser initState = Atto.parseOnly (evalStateT parser initState)