module Parsek
( Parser
, Expect
, Unexpect
, satisfy
, look
, succeeds
, string
, char
, noneOf
, oneOf
, spaces
, space
, newline
, tab
, upper
, lower
, alphaNum
, letter
, digit
, hexDigit
, octDigit
, anyChar
, anySymbol
, munch, munch1
, label
, (<?>)
, pzero
, (<|>)
, (<<|>)
, try
, choice
, option
, optional
, between
, count
, chainl1
, chainl
, chainr1
, chainr
, skipMany1
, skipMany
, many1
, many
, sepBy1
, sepBy
, ParseMethod
, ParseResult
, parseFromFile
, parse
, shortestResult
, longestResult
, longestResults
, allResults
, allResultsStaged
, completeResults
, shortestResultWithLeftover
, longestResultWithLeftover
, longestResultsWithLeftover
, allResultsWithLeftover
, completeResultsWithLine
)
where
import Control.Monad
( MonadPlus(..)
, guard
)
import Data.List
( union
, intersperse
)
import Data.Char
infix 0 <?>
infixr 1 <|>, <<|>
newtype Parser s a
= Parser (forall res . (a -> Expect -> P s res) -> Expect -> P s res)
data P s res
= Symbol (s -> P s res)
| Look ([s] -> P s res)
| Fail Expect Unexpect
| Result res (P s res)
type Expect
= [String]
type Unexpect
= [String]
instance Functor (Parser s) where
fmap p (Parser f) =
Parser (\fut -> f (fut . p))
instance Monad (Parser s) where
return a =
Parser (\fut -> fut a)
Parser f >>= k =
Parser (\fut -> f (\a -> let Parser g = k a in g fut))
fail s =
Parser (\fut exp -> Fail exp [s])
instance MonadPlus (Parser s) where
mzero =
Parser (\fut exp -> Fail exp [])
mplus (Parser f) (Parser g) =
Parser (\fut exp -> f fut exp `plus` g fut exp)
plus :: P s res -> P s res -> P s res
Symbol fut1 `plus` Symbol fut2 = Symbol (\s -> fut1 s `plus` fut2 s)
Fail exp1 err1 `plus` Fail exp2 err2 = Fail (exp1 `union` exp2) (err1 `union` err2)
p `plus` Result res q = Result res (p `plus` q)
Result res p `plus` q = Result res (p `plus` q)
Look fut1 `plus` Look fut2 = Look (\s -> fut1 s `plus` fut2 s)
Look fut1 `plus` q = Look (\s -> fut1 s `plus` q)
p `plus` Look fut2 = Look (\s -> p `plus` fut2 s)
p@(Symbol _) `plus` _ = p
_ `plus` q@(Symbol _) = q
anySymbol :: Parser s s
anySymbol =
Parser (\fut exp -> Symbol (\c ->
fut c []
))
satisfy :: Show s => (s -> Bool) -> Parser s s
satisfy pred =
Parser (\fut exp -> Symbol (\c ->
if pred c
then fut c []
else Fail exp [show [c]]
))
label :: Parser s a -> String -> Parser s a
label (Parser f) s =
Parser (\fut exp ->
if null exp
then f (\a _ -> fut a []) [s]
else f fut exp
)
look :: Parser s [s]
look =
Parser (\fut exp ->
Look (\s -> fut s exp)
)
succeeds :: Parser s a -> Parser s (Maybe a)
succeeds (Parser f) =
Parser (\fut exp ->
Look (\xs ->
let sim (Symbol f) q (x:xs) = sim (f x) (\k -> Symbol (\_ -> q k)) xs
sim (Look f) q xs = sim (f xs) q xs
sim p@(Result _ _) q xs = q (cont p)
sim _ _ _ = fut Nothing []
cont (Symbol f) = Symbol (\x -> cont (f x))
cont (Look f) = Look (\s -> cont (f s))
cont (Result a p) = fut (Just a) [] `plus` cont p
cont (Fail exp unexp) = Fail exp unexp
in sim (f (\a _ -> Result a (Fail [] [])) exp) id xs
)
)
string :: (Eq s, Show s) => [s] -> Parser s [s]
string s =
Parser (\fut exp ->
let inputs [] = fut s []
inputs (x:xs) =
Symbol (\c ->
if c == x
then inputs xs
else Fail (if null exp then [show s] else exp) [show [c]]
)
in inputs s
)
char c = satisfy (==c) <?> show [c]
noneOf cs = satisfy (\c -> not (c `elem` cs))
oneOf cs = satisfy (\c -> c `elem` cs)
spaces = skipMany space <?> "white space"
space = satisfy (isSpace) <?> "space"
newline = char '\n' <?> "new-line"
tab = char '\t' <?> "tab"
upper = satisfy (isUpper) <?> "uppercase letter"
lower = satisfy (isLower) <?> "lowercase letter"
alphaNum = satisfy (isAlphaNum) <?> "letter or digit"
letter = satisfy (isAlpha) <?> "letter"
digit = satisfy (isDigit) <?> "digit"
hexDigit = satisfy (isHexDigit) <?> "hexadecimal digit"
octDigit = satisfy (isOctDigit) <?> "octal digit"
anyChar = anySymbol
munch :: (s -> Bool) -> Parser s [s]
munch p =
do cs <- look
scan cs
where
scan (c:cs) | p c = do anySymbol; as <- scan cs; return (c:as)
scan _ = do return []
munch1 :: Show s => (s -> Bool) -> Parser s [s]
munch1 p =
do c <- satisfy p
cs <- munch p
return (c:cs)
(<?>) :: Parser s a -> String -> Parser s a
p <?> s = label p s
pzero :: Parser s a
pzero = mzero
(<|>) :: Parser s a -> Parser s a -> Parser s a
p <|> q = p `mplus` q
(<<|>) :: Parser s a -> Parser s a -> Parser s a
p <<|> q =
do ma <- succeeds p
case ma of
Nothing -> q
Just a -> return a
try :: Parser s a -> Parser s a
try p = p
choice :: [Parser s a] -> Parser s a
choice ps = foldr (<|>) mzero ps
option :: a -> Parser s a -> Parser s a
option x p = p <|> return x
optional :: Parser s a -> Parser s ()
optional p = (do p; return ()) <|> return ()
between :: Parser s open -> Parser s close -> Parser s a -> Parser s a
between open close p = do open; x <- p; close; return x
skipMany1,skipMany :: Parser s a -> Parser s ()
skipMany1 p = do p; skipMany p
skipMany p = let scan = (do p; scan) <|> return () in scan
many1,many :: Parser s a -> Parser s [a]
many1 p = do x <- p; xs <- many p; return (x:xs)
many p = let scan f = (do x <- p; scan (f.(x:))) <|> return (f []) in scan id
sepBy1,sepBy :: Parser s a -> Parser s sep -> Parser s [a]
sepBy p sep = sepBy1 p sep <|> return []
sepBy1 p sep = do x <- p; xs <- many (do sep; p); return (x:xs)
count :: Int -> Parser s a -> Parser s [a]
count n p = sequence (replicate n p)
chainr,chainl :: Parser s a -> Parser s (a -> a -> a) -> a -> Parser s a
chainr p op x = chainr1 p op <|> return x
chainl p op x = chainl1 p op <|> return x
chainr1,chainl1 :: Parser s a -> Parser s (a -> a -> a) -> Parser s a
chainr1 p op = scan
where
scan = do x <- p; rest x
rest x = (do f <- op; y <- scan; return (f x y)) <|> return x
chainl1 p op = scan
where
scan = do x <- p; rest x
rest x = (do f <- op; y <- p; rest (f x y)) <|> return x
type ParseMethod s a e r
= P s a -> [s] -> ParseResult e r
type ParseResult e r
= Either (e, Expect, Unexpect) r
parseFromFile :: Parser Char a -> ParseMethod Char a e r -> FilePath -> IO (ParseResult e r)
parseFromFile p method file =
do s <- readFile file
return (parse p method s)
parse :: Parser s a -> ParseMethod s a e r -> [s] -> ParseResult e r
parse (Parser f) method xs =
case method (f (\a exp -> Result a (Fail exp [])) []) xs of
Left (err, exp, unexp) -> Left (err, [ s | s@(_:_) <- exp ], unexp)
Right x -> Right x
shortestResult :: ParseMethod s a (Maybe s) a
shortestResult p xs = scan p xs
where
scan (Symbol sym) (x:xs) = scan (sym x) xs
scan (Symbol _) [] = scan (Fail [] []) []
scan (Result res _) _ = Right res
scan (Fail exp err) (x:xs) = failSym x exp err
scan (Fail exp err) [] = failEof exp err
scan (Look f) xs = scan (f xs) xs
longestResult :: ParseMethod s a (Maybe s) a
longestResult p xs = scan p Nothing xs
where
scan (Symbol sym) mres (x:xs) = scan (sym x) mres xs
scan (Symbol _) mres [] = scan (Fail [] []) mres []
scan (Result res p) _ xs = scan p (Just res) xs
scan (Fail exp err) Nothing (x:xs) = failSym x exp err
scan (Fail exp err) Nothing [] = failEof exp err
scan (Fail _ _) (Just res) _ = Right res
scan (Look f) mres xs = scan (f xs) mres xs
longestResults :: ParseMethod s a (Maybe s) [a]
longestResults p xs = scan p [] [] xs
where
scan (Symbol sym) [] old (x:xs) = scan (sym x) [] old xs
scan (Symbol sym) new old (x:xs) = scan (sym x) [] new xs
scan (Symbol _) new old [] = scan (Fail [] []) new old []
scan (Result res p) new old xs = scan p (res:new) [] xs
scan (Fail exp err) [] [] (x:xs) = failSym x exp err
scan (Fail exp err) [] [] [] = failEof exp err
scan (Fail _ _) [] old _ = Right old
scan (Fail _ _) new _ _ = Right new
scan (Look f) new old xs = scan (f xs) new old xs
allResultsStaged :: ParseMethod s a (Maybe s) [[a]]
allResultsStaged p xs = Right (scan p [] xs)
where
scan (Symbol sym) ys (x:xs) = ys : scan (sym x) [] xs
scan (Symbol _) ys [] = [ys]
scan (Result res p) ys xs = scan p (res:ys) xs
scan (Fail _ _) ys _ = [ys]
scan (Look f) ys xs = scan (f xs) ys xs
allResults :: ParseMethod s a (Maybe s) [a]
allResults p xs = scan p xs
where
scan (Symbol sym) (x:xs) = scan (sym x) xs
scan (Symbol _) [] = scan (Fail [] []) []
scan (Result res p) xs = Right (res : scan' p xs)
scan (Fail exp err) (x:xs) = failSym x exp err
scan (Fail exp err) [] = failEof exp err
scan (Look f) xs = scan (f xs) xs
scan' p xs =
case scan p xs of
Left _ -> []
Right ress -> ress
completeResults :: ParseMethod s a (Maybe s) [a]
completeResults p xs = scan p xs
where
scan (Symbol sym) (x:xs) = scan (sym x) xs
scan (Symbol _) [] = scan (Fail [] []) []
scan (Result res p) [] = Right (res : scan' p [])
scan (Result _ p) xs = scan p xs
scan (Fail exp err) (x:xs) = failSym x exp err
scan (Fail exp err) [] = failEof exp err
scan (Look f) xs = scan (f xs) xs
scan' p xs =
case scan p xs of
Left _ -> []
Right ress -> ress
shortestResultWithLeftover :: ParseMethod s a (Maybe s) (a,[s])
shortestResultWithLeftover p xs = scan p xs
where
scan (Symbol sym) (x:xs) = scan (sym x) xs
scan (Symbol _) [] = scan (Fail [] []) []
scan (Result res _) xs = Right (res,xs)
scan (Fail exp err) (x:xs) = failSym x exp err
scan (Fail exp err) [] = failEof exp err
scan (Look f) xs = scan (f xs) xs
longestResultWithLeftover :: ParseMethod s a (Maybe s) (a,[s])
longestResultWithLeftover p xs = scan p Nothing xs
where
scan (Symbol sym) mres (x:xs) = scan (sym x) mres xs
scan (Symbol _) mres [] = scan (Fail [] []) mres []
scan (Result res p) _ xs = scan p (Just (res,xs)) xs
scan (Fail exp err) Nothing (x:xs) = failSym x exp err
scan (Fail exp err) Nothing [] = failEof exp err
scan (Fail _ _) (Just resxs) _ = Right resxs
scan (Look f) mres xs = scan (f xs) mres xs
longestResultsWithLeftover :: ParseMethod s a (Maybe s) ([a],Maybe [s])
longestResultsWithLeftover p xs = scan p empty empty xs
where
scan (Symbol sym) ([],_) old (x:xs) = scan (sym x) empty old xs
scan (Symbol sym) new old (x:xs) = scan (sym x) empty new xs
scan (Symbol _) new old [] = scan (Fail [] []) new old []
scan (Result res p) (as,_) old xs = scan p (res:as,Just xs) empty xs
scan (Fail exp err) ([],_) ([],_) (x:xs) = failSym x exp err
scan (Fail exp err) ([],_) ([],_) [] = failEof exp err
scan (Fail _ _) ([],_) old _ = Right old
scan (Fail _ _) new _ _ = Right new
scan (Look f) new old xs = scan (f xs) new old xs
empty = ([],Nothing)
allResultsWithLeftover :: ParseMethod s a (Maybe s) [(a,[s])]
allResultsWithLeftover p xs = scan p xs
where
scan (Symbol sym) (x:xs) = scan (sym x) xs
scan (Symbol _) [] = scan (Fail [] []) []
scan (Result res p) xs = Right ((res,xs) : scan' p xs)
scan (Fail exp err) (x:xs) = failSym x exp err
scan (Fail exp err) [] = failEof exp err
scan (Look f) xs = scan (f xs) xs
scan' p xs =
case scan p xs of
Left _ -> []
Right ress -> ress
completeResultsWithLine :: ParseMethod Char a Int [a]
completeResultsWithLine p xs = scan p 1 xs
where
scan (Symbol sym) n (x:xs) = let n' = x |> n in n' `seq` scan (sym x) n' xs
scan (Symbol _) n [] = scan (Fail [] ["end of file"]) n []
scan (Result res p) n [] = Right (res : scan' p n [])
scan (Result _ p) n xs = scan p n xs
scan (Fail exp err) n xs = Left (n, exp, err)
scan (Look f) n xs = scan (f xs) n xs
scan' p n xs =
case scan p n xs of
Left _ -> []
Right ress -> ress
'\n' |> n = n+1
_ |> n = n
failSym :: s -> Expect -> Unexpect -> ParseResult (Maybe s) r
failSym s exp err = Left (Just s, exp, err)
failEof :: Expect -> Unexpect -> ParseResult (Maybe s) r
failEof exp err = Left (Nothing, exp, err ++ ["end of file"])