Generalize the Parser type into a MonadParser class to use with MonadTrans and remove redundant code already defined in Applicative or Attoparsec

src/PDF/Body.hs

@@ -6,6 +6,7 @@ module PDF.Body (
 
 import Control.Applicative ((<|>))
 import Control.Monad.State (get, gets, modify)
+import Data.Attoparsec.ByteString.Char8 (option)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as BS (cons, drop, unpack)
 import Data.Map ((!))
@@ -18,7 +19,7 @@ import PDF.Object (
     , blank, dictionary, directObject, integer, line
   )
 import PDF.Output (ObjectId(..), Offset(..))
-import PDF.Parser (Parser, (<?>), block, char, evalParser, on, option, takeAll)
+import PDF.Parser (Parser, (<?>), block, char, evalParser, on, takeAll)
 
 data UserState = UserState {
       input :: ByteString

src/PDF/Object.hs

@@ -28,7 +28,8 @@ module PDF.Object (
     , structure
   ) where
 
-import Control.Applicative ((<|>))
+import Control.Applicative ((<|>), many)
+import Data.Attoparsec.ByteString.Char8 (choice, count, option, sepBy)
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as BS (
     concat, cons, pack, singleton, unpack
@@ -44,11 +45,7 @@ import PDF.Output (
     , byteString, getObjectId, getOffset, getOffsets, join, newLine
     , saveOffset
   )
-import PDF.Parser (
-      Parser, (<?>)
-    , char, choice, count, decNumber, hexNumber, many, octDigit, oneOf, option
-    , sepBy, string, takeAll, takeAll1
-  )
+import PDF.Parser (MonadParser(..), Parser, (<?>), octDigit, oneOf)
 import Text.Printf (printf)
 
 line :: String -> Parser u ()
@@ -63,8 +60,8 @@ eofMarker = "%%EOF"
 whiteSpaceCharset :: String
 whiteSpaceCharset = "\0\t\12 "
 
-blank :: Parser u ()
-blank = takeAll (`elem` (EOL.charset ++ whiteSpaceCharset)) *> return ()
+blank :: MonadParser m => m ()
+blank = takeAll (`elem` (EOL.charset ++ whiteSpaceCharset)) *> pure ()
 
 delimiterCharset :: String
 delimiterCharset = "()<>[]{}/%"
@@ -140,7 +137,7 @@ newtype Name = Name String deriving (Eq, Ord, Show)
 instance Output Name where
   output (Name n) = Output.string ('/':n)
 
-name :: Parser u Name
+name :: MonadParser m => m Name
 name = Name . BS.unpack <$> (char '/' *> takeAll regular) <?> "name"
 
 --

src/PDF/Parser.hs

@@ -1,28 +1,29 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE UndecidableInstances #-}
 module PDF.Parser (
-      Parser
+      MonadParser
+    , Parser
     , (<?>)
     , block
     , char
-    , choice
-    , count
     , decNumber
     , hexNumber
-    , many
     , octDigit
     , on
     , oneOf
-    , option
     , runParser
     , evalParser
-    , sepBy
     , string
     , takeAll
     , takeAll1
   ) where
 
-import Control.Applicative ((<|>), empty)
+import Control.Applicative (Alternative, (<|>))
+import Control.Monad (MonadPlus)
+import Control.Monad.Fail (MonadFail(..))
 import Control.Monad.State (StateT(..), evalStateT)
-import Control.Monad.Trans (lift)
+import Control.Monad.Trans (MonadTrans(..))
 import qualified Data.Attoparsec.ByteString.Char8 as Atto (
     Parser, char, parseOnly, satisfy, string, take, takeWhile, takeWhile1
   )
@@ -30,28 +31,45 @@ import Data.ByteString (ByteString)
 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
+  hexNumber :: m ByteString
+  oneOf :: String -> 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
+  decNumber = Atto.takeWhile1 (`Set.member` digits)
+  hexNumber = Atto.takeWhile1 (`Set.member` hexDigits)
+  oneOf charSet = Atto.satisfy (`elem` charSet)
+  string = Atto.string
+  takeAll = Atto.takeWhile
+  takeAll1 = Atto.takeWhile1
+
+instance (MonadParser m, MonadTrans t, MonadDeps (t m)) => MonadParser (t m) where
+  block = lift . block
+  char = lift . char
+  decNumber = lift $ decNumber
+  hexNumber = lift $ hexNumber
+  oneOf = lift . oneOf
+  string = lift . string
+  takeAll = lift . takeAll
+  takeAll1 = lift . takeAll1
 
 type Parser s = StateT s Atto.Parser
 
-(<?>) :: Parser s a -> String -> Parser s a
+(<?>) :: (Alternative m, MonadFail m) => m a -> String -> m a
 (<?>) parser debugMessage = parser <|> fail debugMessage
 
-block :: Int -> Parser s ByteString
-block = lift . Atto.take
-
-char :: Char -> Parser s Char
-char = lift . Atto.char
-
-choice :: [Parser s a] -> Parser s a
-choice = foldr (<|>) empty
-
-count :: Int -> Parser s a -> Parser s [a]
-count 0 _ = return []
-count n p = (:) <$> p <*> count (n-1) p
-
-decNumber :: Parser s ByteString
-decNumber = lift $ Atto.takeWhile1 (`Set.member` digits)
-
 digits :: Set Char
 digits = Set.fromList ['0'..'9']
 
@@ -60,13 +78,7 @@ hexDigits = Set.unions [digits, Set.fromList af, Set.fromList $ toLower <$> af]
   where
     af = ['A'..'F']
 
-hexNumber :: Parser s ByteString
-hexNumber = lift $ Atto.takeWhile1 (`Set.member` hexDigits)
-
-many :: Parser s a -> Parser s [a]
-many parser = (:) <$> parser <*> many parser <|> return []
-
-octDigit :: Parser s Char
+octDigit :: MonadParser m => m Char
 octDigit = oneOf ['0'..'7']
 
 on :: Parser s a -> ByteString -> Parser s (Either String a)
@@ -75,27 +87,8 @@ on (StateT parserF) input = StateT $ \state ->
     Left errorMsg -> return (Left errorMsg, state)
     Right (result, newState) -> return (Right result, newState)
 
-oneOf :: String -> Parser s Char
-oneOf charSet = lift $ Atto.satisfy (`elem` charSet)
-
-option :: a -> Parser s a -> Parser s a
-option defaultValue p = p <|> pure defaultValue
-
 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)
-
-sepBy :: Parser s a -> Parser s b -> Parser s [a]
-sepBy parser separator =
-  option [] $ (:) <$> parser <*> many (separator *> parser)
-
-string :: ByteString -> Parser s ByteString
-string = lift . Atto.string
-
-takeAll :: (Char -> Bool) -> Parser s ByteString
-takeAll = lift . Atto.takeWhile
-
-takeAll1 :: (Char -> Bool) -> Parser s ByteString
-takeAll1 = lift . Atto.takeWhile1