module Encode.Extend (
module PureFP.Parsers.Parser,
ExtEnv,
Extend (..),
initEnv,
inspectIList, returnIList,
inspectEList, returnEList,
inspectEnv, resetEnv,
oneof, lower, upper, upperWith, oneof',
(<|>),
again, lookupList
) where
import PureFP.OrdMap
import PureFP.Parsers.Parser
import Control.Monad
import Version
version = revised "$Revision: 291 $"
class ExtEnv e where
initEnv :: e i
newtype Extend e s a = Ext (InE s e -> [(InE s e, a)])
type InE i e = ([i], [e i])
inspectIList :: Extend e s [s]
inspectIList = Ext (\ (i, e) -> [((i, e), i)])
returnIList :: [s] -> Extend e s [s]
returnIList i = Ext (\ (_, e) -> [((i, e), i)])
inspectEList :: Extend e s [e s]
inspectEList = Ext (\ (i, e) -> [((i, e), e)])
returnEList :: [e s] -> Extend e s [e s]
returnEList e = Ext (\ (i, _) -> [((i, e), e)])
inspectEnv :: Extend e s (e s)
inspectEnv = Ext (\ (i, e) -> [((i, e), head e)])
resetEnv :: (a -> e s -> e s) -> a -> Extend e s (e s)
resetEnv f v = Ext (\ (i, e : q) -> [((i, f v e : q), f v e)])
infixr 2 <|>
(<|>) :: Extend e s a -> Extend e s a -> Extend e s a
(<|>) p q = Ext (\ cs -> let Ext pp = p
r = pp cs
Ext qq = q
t = qq cs
takeOne (x:_) = [x]
takeOne [] = []
in case r of [] -> takeOne t
_ -> takeOne r )
again :: Extend e s a -> Extend e s [a]
again p = ps where ps = p <:> ps <|> return []
lookupList :: (OrdMap m, Ord s) => s -> [m s a] -> [a]
lookupList x l = concat [ maybe [] (: []) (i ? x) | i <- l ]
oneof' :: (Ord [s], Symbol m [s], Eq s, Monad m) => s -> [Map [s] a] -> m [s]
oneof' p l = do y <- sat (\ (x : s) -> if x == p
then any (\ i -> maybe False (const True) (i ? s)) l
else False)
return (tail y)
oneof :: (Ord s, Symbol m s) => [Map s a] -> m s
oneof l = sat (\ s -> any (\ i -> maybe False (const True) (i ? s)) l)
lower :: (Ord s) => [s] -> [s] -> Extend e s [s]
lower s c = Ext (\ inp -> [ ((c ++ i, e), r) | ((i, e), r) <- f inp ])
where Ext f = syms s
upper :: (OrdMap m, Ord s) => [s] -> [m s [c]] -> Extend e d ([c] -> [c])
upper s l = foldM (\ f -> fmap ((.) f) . anyof . map (return . (++))) id
[ lookupList x l | x <- s ]
upperWith :: (s -> m -> e d -> [[c]]) -> [s] -> m -> Extend e d ([c] -> [c])
upperWith f s l =
do e <- inspectEnv
foldM (\ f -> fmap ((.) f) . anyof . map (return . (++))) id
[ f x l e | x <- s ]
instance Monoid (Extend e s) where
zero = Ext (\ inp -> [])
Ext p <+> Ext q = Ext (\ inp -> p inp ++ q inp)
instance Monad (Extend e s) where
return a = Ext (\ inp -> [(inp, a)])
Ext p >>= k = Ext (\ inp -> concat [ q inp' | (inp', a) <- p inp,
let Ext q = k a ])
instance Functor (Extend e s) where
fmap f p = do a <- p; return (f a)
instance Sequence (Extend e s)
instance Eq s => Symbol (Extend e s) s where
sat p = Ext sat'
where sat' ((s:inp), e) | p s = [((inp, e), s)]
sat' _ = []
instance Eq s => SymbolCont (Extend e s) s where
satCont p fut = Ext sat'
where sat' ((s:inp), e) | p s = let Ext p = fut s in p (inp, e)
sat' _ = []
instance ExtEnv e => Parser (Extend e s) s where
parse = parse' initEnv
parseFull = parseFull' initEnv
instance Lookahead (Extend e s) s where
lookahead f = Ext (\ (inp, e) -> let Ext p = f inp in p (inp, e))
parse' :: ExtEnv e => e s -> Extend e s a -> [s] -> [([s], a)]
parse' e (Ext p) i = [ (x, y) | ((x, _), y) <- p (i, [e]) ]
parseFull' :: ExtEnv e => e s -> Extend e s a -> [s] -> [a]
parseFull' e (Ext p) i = [ y | (([], _), y) <- p (i, [e]) ]