module Encode.ExPlus (
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 PureFP.Parsers.Standard
import Control.Monad
import Control.Monad.State
import Control.Monad.Trans
import Version
version = revised "$Revision: 455 $"
class ExtEnv e where
initEnv :: e i
type Extend e s = StateT [e s] (Standard s)
inspectIList :: Extend e s [s]
inspectIList = lift get
returnIList :: [s] -> Extend e s [s]
returnIList i = lift (put i >> return i)
inspectEList :: Extend e s [e s]
inspectEList = get
returnEList :: [e s] -> Extend e s [e s]
returnEList e = put e >> return e
inspectEnv :: Extend e s (e s)
inspectEnv = gets head
resetEnv :: (a -> e s -> e s) -> a -> Extend e s (e s)
resetEnv f v = modify (\(e : q) -> f v e : q) >> gets head
infixr 2 <|>
(<|>) :: Extend e s a -> Extend e s a -> Extend e s a
(<|>) p q = StateT (\s -> Std (\inp -> let Std pp = runStateT p s
r = pp inp
Std qq = runStateT q s
t = qq inp
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 = lift (syms s >> modify (c ++) >> get)
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 = lift zero
p <+> q = StateT (\s -> runStateT p s <+> runStateT q s)
instance Sequence (Extend e s)
instance Eq s => Symbol (Extend e s) s where
sat p = lift (sat p)
instance ExtEnv e => Parser (Extend e s) s where
parse p = parse (evalStateT p [initEnv])
parseFull p = parseFull (evalStateT p [initEnv])