module Data.JustParse.Common (
Stream(..),
Result(..),
Parser( parse ),
finalize,
extend,
justParse,
runParser,
isDone,
isFail,
isPartial,
rename,
(<?>),
satisfy,
mN,
test,
greedy,
option,
many,
many1,
manyN,
atLeast,
exactly,
eof,
oneOf,
noneOf,
anyToken,
lookAhead,
char,
anyChar,
ascii,
latin1,
control,
space,
lower,
upper,
alpha,
alphaNum,
print,
digit,
octDigit,
hexDigit,
eol,
string,
) where
import Prelude hiding ( print, length )
import Data.JustParse.Internal ( Stream(..), Parser(..), Result(..), extend, finalize, isDone, isPartial, isFail, rename, (<?>) )
import Data.Monoid ( mempty, Monoid )
import Data.Maybe ( fromMaybe )
import Data.List ( minimumBy )
import Data.Char ( isControl, isSpace, isLower, isUpper, isAlpha, isAlphaNum, isPrint,
isDigit, isOctDigit, isHexDigit, isLetter, isMark, isNumber, isPunctuation,
isSymbol, isSeparator, isAscii, isLatin1, isAsciiUpper, isAsciiLower )
import Data.Ord ( comparing )
import Control.Monad ( void, (>=>), liftM )
import Control.Applicative ( (<|>), optional, (<*) )
runParser :: Parser s a -> s -> [Result s a]
runParser p = parse p . Just
justParse :: Stream s t => Parser s a -> s -> Maybe a
justParse p s =
case finalize (parse (greedy p) (Just s)) of
[] -> Nothing
(Done v _:_) -> Just v
(Fail m _:_) -> Nothing
satisfy :: Stream s t => (t -> Bool) -> Parser s t
satisfy f = Parser $ \s ->
case s of
Nothing -> [Fail ["satisfy"] s]
Just s' -> case uncons s' of
Nothing -> [Partial $ parse (satisfy f)]
Just (x, xs) ->
if f x
then [Done x (Just xs)]
else [Fail ["satisfy"] s]
mN :: Int -> Int -> Parser s a -> Parser s [a]
mN m n p = mN' m n p <?> "mN"
mN' :: Int -> Int -> Parser s a -> Parser s [a]
mN' _ 0 _ = Parser $ \s -> [Done [] s]
mN' m n p = Parser $ \s ->
if m == 0
then Done [] s : (parse p s >>= g)
else parse p s >>= g
where
m' = if m == 0 then 0 else m1
g (Done a s) = parse (mN' m' (n1) p) s >>= h a
g (Partial p') = [Partial $ p' >=> g]
g (Fail m l) = [Fail m l]
h a (Done as s) = [Done (a:as) s]
h a (Partial p') = [Partial $ p' >=> h a]
h a (Fail m l) = [Fail m l]
test :: Parser s a -> Parser s Bool
test p =
do
a <- optional (lookAhead p)
case a of
Nothing -> return False
_ -> return True
greedy :: Stream s t => Parser s a -> Parser s a
greedy (Parser p) = Parser $ \s -> g (p s)
where
b (Done _ _) = True
b (Fail _ _) = True
b _ = False
f Nothing = 0
f (Just s) = length s
g [] = []
g xs
| all b xs =
let
ds = filter isDone xs
dm = minimum (map (f . leftover) ds)
fs = filter isFail xs
fm = minimum (map (f . leftover) fs)
in
if not (null ds)
then filter ((dm==) . f . leftover) ds
else filter ((fm==) . f . leftover) fs
| otherwise = [Partial $ \s -> g $ extend s xs]
option :: a -> Parser s a -> Parser s a
option v p =
do
r <- optional p
case r of
Nothing -> return v
Just v' -> return v'
many :: Parser s a -> Parser s [a]
many p = rename "many" (mN 0 (1) p)
many1 :: Parser s a -> Parser s [a]
many1 p = rename "many1" (mN 1 (1) p)
manyN :: Int -> Parser s a -> Parser s [a]
manyN n p = rename "manyN" (mN n (1) p)
atLeast :: Int -> Parser s a -> Parser s [a]
atLeast n p = rename "atLeast" (mN n (1) p)
exactly :: Int -> Parser s a -> Parser s [a]
exactly n p = rename "exactly" (mN n n p)
eof :: (Eq s, Monoid s) => Parser s ()
eof = Parser $ \s ->
case s of
Nothing -> [Done () s]
Just s' ->
if s' == mempty
then [Partial $ parse eof]
else [Fail ["eof"] (Just s')]
oneOf :: (Eq t, Stream s t) => [t] -> Parser s t
oneOf ts = rename "oneOf" (satisfy (`elem` ts))
noneOf :: (Eq t, Stream s t) => [t] -> Parser s t
noneOf ts = rename "noneOf" (satisfy (not . (`elem` ts)))
token :: (Eq t, Stream s t) => t -> Parser s t
token t = rename "token" (satisfy (==t))
anyToken :: Stream s t => Parser s t
anyToken = rename "anyToken" (satisfy (const True))
lookAhead :: Parser s a -> Parser s a
lookAhead (Parser p) = rename "lookAhead" $ Parser $ \s ->
let
g (Done a _) = [Done a s]
g (Partial p') = [Partial $ p' >=> g]
g (Fail m _) = [Fail m s]
in
p s >>= g
char :: Stream s Char => Char -> Parser s Char
char c = rename ("char "++[c]) (token c)
anyChar :: Stream s Char => Parser s Char
anyChar = rename "anyChar" anyToken
ascii :: Stream s Char => Parser s Char
ascii = rename "ascii" (satisfy isAscii)
latin1 :: Stream s Char => Parser s Char
latin1 = rename "latin1" (satisfy isLatin1)
control :: Stream s Char => Parser s Char
control = rename "control" (satisfy isControl)
space :: Stream s Char => Parser s Char
space = rename "space" (satisfy isSpace)
lower :: Stream s Char => Parser s Char
lower = rename "lower" (satisfy isLower)
upper :: Stream s Char => Parser s Char
upper = rename "upper" (satisfy isUpper)
alpha :: Stream s Char => Parser s Char
alpha = rename "alpha" (satisfy isAlpha)
alphaNum :: Stream s Char => Parser s Char
alphaNum = rename "alphaNum" (satisfy isAlphaNum)
print :: Stream s Char => Parser s Char
print = rename "print" (satisfy isPrint)
digit :: Stream s Char => Parser s Char
digit = rename "digit" (satisfy isDigit)
octDigit :: Stream s Char => Parser s Char
octDigit = rename "octDigit" (satisfy isOctDigit)
hexDigit :: Stream s Char => Parser s Char
hexDigit = rename "hexDigit" (satisfy isHexDigit)
string :: Stream s Char => String -> Parser s String
string s = rename ("string "++s) (mapM char s)
eol :: Stream s Char => Parser s String
eol = rename "eol" (string "\r\n" <|> string "\n\r" <|> string "\n")
instance (Eq t) => Stream [t] t where
uncons [] = Nothing
uncons (x:xs) = Just (x, xs)