{-# LANGUAGE CPP #-}
module Text.Packrat.Parse where
import Prelude hiding (exp, rem)
import Data.Char
import Data.List
import Text.Packrat.Pos
import Control.Monad
import Control.Applicative (Applicative(..))
import qualified Control.Applicative as A
import qualified Control.Monad.Fail as Fail
data Message = Expected String
| Message String
data ParseError = ParseError { errorPos :: Pos
, errorMessages :: [Message] }
data Result d v = Parsed v d ParseError
| NoParse ParseError
newtype Parser d v = Parser (d -> Result d v)
class Derivs d where
dvPos :: d -> Pos
dvChar :: d -> Result d Char
infixl 2 <|>
infixl 1 <?>
infixl 1 <?!>
instance Derivs d => Functor (Parser d) where
f `fmap` (Parser p1) = Parser $ parse . p1
where parse (Parsed val rem err) =
let val2 = f val
in Parsed val2 rem err
parse (NoParse err) = NoParse err
instance Derivs d => Applicative (Parser d) where
pure x = Parser (\dvs -> Parsed x dvs (nullError dvs))
(<*>) = ap
instance Derivs d => Monad (Parser d) where
(Parser p1) >>= f = Parser parse
where parse dvs = first (p1 dvs)
first (Parsed val rem err) =
let Parser p2 = f val
in second err (p2 rem)
first (NoParse err) = NoParse err
second err1 (Parsed val rem err) =
Parsed val rem (joinErrors err1 err)
second err1 (NoParse err) =
NoParse (joinErrors err1 err)
return = pure
#if !(MIN_VERSION_base(4,13,0))
fail = Fail.fail
#endif
instance Derivs d => Fail.MonadFail (Parser d) where
fail msg = Parser (\dvs -> NoParse (msgError (dvPos dvs) msg))
instance Derivs d => A.Alternative (Parser d) where
empty = Parser $ NoParse . nullError
(<|>) = (<|>)
instance Derivs d => MonadPlus (Parser d) where
mzero = A.empty
mplus = (A.<|>)
(<|>) :: Derivs d => Parser d v -> Parser d v -> Parser d v
(Parser p1) <|> (Parser p2) = Parser parse
where parse dvs = first dvs (p1 dvs)
first _ (result @ (Parsed {})) = result
first dvs (NoParse err) = second err (p2 dvs)
second err1 (Parsed val rem err) =
Parsed val rem (joinErrors err1 err)
second err1 (NoParse err) =
NoParse (joinErrors err1 err)
satisfy :: Derivs d => Parser d v -> (v -> Bool) -> Parser d v
satisfy (Parser p) test = Parser parse
where parse dvs = check dvs (p dvs)
check dvs (result @ (Parsed val _ _)) =
if test val
then result
else NoParse (nullError dvs)
check _ none = none
notFollowedBy :: (Derivs d, Show v) => Parser d v -> Parser d ()
notFollowedBy (Parser p) = Parser parse
where parse dvs = case p dvs of
Parsed val _ _ ->
NoParse (msgError (dvPos dvs)
("unexpected " ++ show val))
NoParse _ -> Parsed () dvs (nullError dvs)
optional :: Derivs d => Parser d v -> Parser d (Maybe v)
optional p = (do v <- p; return (Just v)) <|> return Nothing
option :: Derivs d => v -> Parser d v -> Parser d v
option v p = p <|> return v
many :: Derivs d => Parser d v -> Parser d [v]
many p = (do { v <- p; vs <- many p; return (v : vs) } )
<|> return []
many1 :: Derivs d => Parser d v -> Parser d [v]
many1 p = do { v <- p; vs <- many p; return (v : vs) }
count :: Derivs d => Int -> Parser d v -> Parser d [v]
count = replicateM
sepBy1 :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v]
sepBy1 p psep = do v <- p
vs <- many (do { psep; p })
return (v : vs)
sepBy :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v]
sepBy p psep = sepBy1 p psep <|> return []
endBy :: Derivs d => Parser d v -> Parser d vend -> Parser d [v]
endBy p pend = many (do { v <- p; pend; return v })
endBy1 :: Derivs d => Parser d v -> Parser d vend -> Parser d [v]
endBy1 p pend = many1 (do { v <- p; pend; return v })
sepEndBy1 :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v]
sepEndBy1 p psep = do v <- sepBy1 p psep; optional psep; return v
sepEndBy :: Derivs d => Parser d v -> Parser d vsep -> Parser d [v]
sepEndBy p psep = do v <- sepBy p psep; optional psep; return v
chainl1 :: Derivs d => Parser d v -> Parser d (v->v->v) -> Parser d v
chainl1 p psep = let psuffix z = (do f <- psep
v <- p
psuffix (f z v))
<|> return z
in do v <- p
psuffix v
chainl :: Derivs d => Parser d v -> Parser d (v->v->v) -> v -> Parser d v
chainl p psep z = chainl1 p psep <|> return z
chainr1 :: Derivs d => Parser d v -> Parser d (v->v->v) -> Parser d v
chainr1 p psep = (do v <- p
f <- psep
w <- chainr1 p psep
return (f v w))
<|> p
chainr :: Derivs d => Parser d v -> Parser d (v->v->v) -> v -> Parser d v
chainr p psep z = chainr1 p psep <|> return z
choice :: Derivs d => [Parser d v] -> Parser d v
choice [] = error "choice requires non-empty list"
choice [p] = p
choice (p:ps) = p <|> choice ps
manyTill :: Derivs d => Parser d v -> Parser d vend -> Parser d [v]
manyTill p pend = (pend >> return [])
<|> do tok <- p
rest <- manyTill p pend
return (tok:rest)
between :: Derivs d => Parser d vs -> Parser d ve -> Parser d v -> Parser d v
between s e main = do s
v <- main
e
return v
instance Eq Message where
Expected e1 == Expected e2 = e1 == e2
Message m1 == Message m2 = m1 == m2
_ == _ = False
failAt :: Derivs d => Pos -> String -> Parser d v
failAt pos msg = Parser (const $ NoParse (msgError pos msg))
(<?>) :: Derivs d => Parser d v -> String -> Parser d v
(Parser p) <?> desc = Parser (\dvs -> munge dvs (p dvs))
where munge dvs (Parsed v rem err) =
Parsed v rem (fix dvs err)
munge dvs (NoParse err) =
NoParse (fix dvs err)
fix dvs (err @ (ParseError ep _)) =
if ep > dvPos dvs
then err
else expError (dvPos dvs) desc
(<?!>) :: Derivs d => Parser d v -> String -> Parser d v
(Parser p) <?!> desc = Parser (\dvs -> munge dvs (p dvs))
where munge dvs (Parsed v rem err) =
Parsed v rem (fix dvs err)
munge dvs (NoParse err) =
NoParse (fix dvs err)
fix dvs (ParseError _ _) =
expError (dvPos dvs) desc
joinErrors :: ParseError -> ParseError -> ParseError
joinErrors (e @ (ParseError p m)) (e' @ (ParseError p' m'))
| p' > p || null m = e'
| p > p' || null m' = e
| otherwise = ParseError p (m `union` m')
nullError :: Derivs d => d -> ParseError
nullError dvs = ParseError (dvPos dvs) []
expError :: Pos -> String -> ParseError
expError pos desc = ParseError pos [Expected desc]
msgError :: Pos -> String -> ParseError
msgError pos msg = ParseError pos [Message msg]
eofError :: Derivs d => d -> ParseError
eofError dvs = msgError (dvPos dvs) "end of input"
expected :: Derivs d => String -> Parser d v
expected desc = Parser (\dvs -> NoParse (expError (dvPos dvs) desc))
unexpected :: Derivs d => String -> Parser d v
unexpected str = fail ("unexpected " ++ str)
instance Eq ParseError where
ParseError p1 _ == ParseError p2 _ = p1 == p2
ParseError p1 _ /= ParseError p2 _ = p1 /= p2
instance Ord ParseError where
ParseError p1 _ < ParseError p2 _ = p1 < p2
ParseError p1 _ > ParseError p2 _ = p1 > p2
ParseError p1 _ <= ParseError p2 _ = p1 <= p2
ParseError p1 _ >= ParseError p2 _ = p1 >= p2
max = joinErrors
min _ _ = undefined
instance Show ParseError where
show (ParseError pos []) =
show pos ++ ": unknown error"
show (ParseError pos msgs) = expectmsg expects ++ messages msgs
where expects = getExpects msgs
getExpects [] = []
getExpects (Expected exp : rest) = exp : getExpects rest
getExpects (Message _ : rest) = getExpects rest
expectmsg [] = ""
expectmsg [exp] = show pos ++ ": expecting " ++ exp ++ "\n"
expectmsg [e1, e2] = show pos ++ ": expecting either "
++ e1 ++ " or " ++ e2 ++ "\n"
expectmsg (first : rest) = show pos ++ ": expecting one of: "
++ first ++ expectlist rest ++ "\n"
expectlist [] = ""
expectlist [lst] = ", or " ++ lst
expectlist (mid : rest) = ", " ++ mid ++ expectlist rest
messages [] = []
messages (Expected _ : rest) = messages rest
messages (Message msg : rest) =
show pos ++ ": " ++ msg ++ "\n" ++ messages rest
anyChar :: Derivs d => Parser d Char
anyChar = Parser dvChar
char :: Derivs d => Char -> Parser d Char
char ch = satisfy anyChar (== ch) <?> show ch
oneOf :: Derivs d => [Char] -> Parser d Char
oneOf chs = satisfy anyChar (`elem` chs)
<?> ("one of the characters " ++ show chs)
noneOf :: Derivs d => [Char] -> Parser d Char
noneOf chs = satisfy anyChar (`notElem` chs)
<?> ("any character not in " ++ show chs)
charIf :: Derivs d => (Char -> Bool) -> Parser d Char
charIf p = satisfy anyChar p <?> "predicate is not satisfied"
string :: Derivs d => String -> Parser d String
string str = p str <?> show str
where p [] = return str
p (ch:chs) = do { char ch; p chs }
stringFrom :: Derivs d => [String] -> Parser d String
stringFrom [] = error "stringFrom requires non-empty list"
stringFrom [str] = string str
stringFrom (str : strs) = string str <|> stringFrom strs
upper :: Derivs d => Parser d Char
upper = satisfy anyChar isUpper <?> "uppercase letter"
lower :: Derivs d => Parser d Char
lower = satisfy anyChar isLower <?> "lowercase letter"
letter :: Derivs d => Parser d Char
letter = satisfy anyChar isAlpha <?> "letter"
alphaNum :: Derivs d => Parser d Char
alphaNum = satisfy anyChar isAlphaNum <?> "letter or digit"
digit :: Derivs d => Parser d Char
digit = satisfy anyChar isDigit <?> "digit"
hexDigit :: Derivs d => Parser d Char
hexDigit = satisfy anyChar isHexDigit <?> "hexadecimal digit (0-9, a-f)"
octDigit :: Derivs d => Parser d Char
octDigit = satisfy anyChar isOctDigit <?> "octal digit (0-7)"
newline :: Derivs d => Parser d Char
newline = char '\n'
tab :: Derivs d => Parser d Char
tab = char '\t'
space :: Derivs d => Parser d Char
space = satisfy anyChar isSpace <?> "whitespace character"
spaces :: Derivs d => Parser d [Char]
spaces = many space
eof :: Derivs d => Parser d ()
eof = notFollowedBy anyChar <?> "end of input"
getDerivs :: Derivs d => Parser d d
getDerivs = Parser (\dvs -> Parsed dvs dvs (nullError dvs))
setDerivs :: Derivs d => d -> Parser d ()
setDerivs newdvs = Parser (Parsed () newdvs . nullError)
getPos :: Derivs d => Parser d Pos
getPos = Parser (\dvs -> Parsed (dvPos dvs) dvs (nullError dvs))
dvString :: Derivs d => d -> String
dvString d =
case dvChar d of
NoParse _ -> []
Parsed c rem _ -> c : dvString rem