module Data.JustParse.Internal (
finalize,
extend,
Stream (..),
Parser (..),
Result (..),
isDone,
isFail,
isPartial,
rename,
(<?>)
) where
import Prelude hiding ( length )
import Control.Monad ( MonadPlus, mzero, mplus, (>=>), ap )
import Control.Applicative ( Alternative, Applicative, pure, (<*>), empty, (<|>) )
import Data.Monoid ( Monoid, mempty, mappend )
import Data.List ( intercalate )
class (Eq s, Monoid s) => Stream s t | s -> t where
uncons :: Stream s t => s -> Maybe (t, s)
length :: Stream s t => s -> Int
length s =
case uncons s of
Nothing -> 0
Just (x, xs) -> 1 + length xs
newtype Parser s a =
Parser {
parse :: Maybe s -> [Result s a]
}
instance Monoid (Parser s a) where
mempty = mzero
mappend = mplus
instance Functor (Parser s) where
fmap f (Parser p) = Parser $ \s -> map (fmap f) (p s)
instance Applicative (Parser s) where
pure = return
(<*>) = ap
instance Alternative (Parser s) where
empty = mzero
(<|>) = mplus
instance Monad (Parser s) where
return v = Parser $ \s -> [Done v s]
(Parser p) >>= f = Parser $ p >=> g
where
g (Fail m l) = [Fail m l]
g (Done a s) = parse (f a) s
g (Partial p) = [Partial $ p >=> g]
instance MonadPlus (Parser s) where
mzero = Parser $ const []
mplus (Parser p1) (Parser p2) = Parser (\s -> p1 s ++ p2 s)
data Result s a
=
Partial {
continue :: Maybe s -> [Result s a]
} |
Done {
value :: a,
leftover :: Maybe s
} |
Fail {
messages :: [String],
leftover :: Maybe s
}
isDone :: Result s a -> Bool
isDone (Done _ _) = True
isDone _ = False
isPartial :: Result s a -> Bool
isPartial (Partial _) = True
isPartial _ = False
isFail :: Result s a -> Bool
isFail (Fail _ _) = True
isFail _ = False
instance Functor (Result s) where
fmap f (Partial p) = Partial $ map (fmap f) . p
fmap f (Done a s) = Done (f a) s
fmap f (Fail m l) = Fail m l
instance Show a => Show (Result s a) where
show (Partial _) = "Partial"
show (Done a _) = show a
show (Fail m l) = "Fail: \nIn: " ++ intercalate "\nIn: " m
finalize :: (Eq s, Monoid s) => [Result s a] -> [Result s a]
finalize = extend Nothing
extend :: (Eq s, Monoid s) => Maybe s -> [Result s a] -> [Result s a]
extend s rs = rs >>= g
where
g (Fail m l) = [Fail m (f l s)]
g (Partial p) = p s
g (Done a s') = [Done a (f s' s)]
f Nothing _ = Nothing
f (Just s) Nothing = if s == mempty then Nothing else Just s
f s s' = mappend s s'
rename :: String -> Parser s a -> Parser s a
rename s p = Parser (map g . parse p)
where
g v@(Fail m l) = Fail (s:m) l
g v = v
infixl 0 <?>
(<?>) :: Parser s a -> String -> Parser s a
p <?> s = rename s p