module Text.Earley.Internal where
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.Fix
import Control.Monad.ST
import Data.ListLike(ListLike)
import qualified Data.ListLike as ListLike
import Data.STRef
import Text.Earley.Grammar
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif
data Rule s r e t a = Rule
{ ruleProd :: ProdR s r e t a
, ruleNullable :: !(STRef s (Maybe [a]))
, ruleConts :: !(STRef s (STRef s [Cont s r e t a r]))
}
type ProdR s r e t a = Prod (Rule s r) e t a
nullable :: Rule s r e t a -> ST s [a]
nullable r = do
mn <- readSTRef $ ruleNullable r
case mn of
Just xs -> return xs
Nothing -> do
writeSTRef (ruleNullable r) $ Just mempty
res <- nullableProd $ ruleProd r
writeSTRef (ruleNullable r) $ Just res
return res
nullableProd :: ProdR s r e t a -> ST s [a]
nullableProd (Terminal _ _) = return mempty
nullableProd (NonTerminal r p) = do
as <- nullable r
concat <$> mapM (\a -> nullableProd $ fmap ($ a) p) as
nullableProd (Pure a) = return [a]
nullableProd (Alts as p) = (\ass fs -> fs <*> concat ass)
<$> mapM nullableProd as <*> nullableProd p
nullableProd (Many p q) = do
as <- nullableProd $ (:[]) <$> p <|> pure []
concat <$> mapM (\a -> nullableProd $ fmap ($ a) q) as
nullableProd (Named p _) = nullableProd p
resetConts :: Rule s r e t a -> ST s ()
resetConts r = writeSTRef (ruleConts r) =<< newSTRef []
type Args s f a = f -> ST s [a]
noArgs :: Args s a a
noArgs = return . pure
funArg :: (f -> a) -> Args s f a
funArg f = mapArgs f noArgs
pureArg :: x -> Args s f a -> Args s (x -> f) a
pureArg x args = args . ($ x)
pureArgs :: [x] -> Args s f a -> Args s (x -> f) a
pureArgs xs args f = concat <$> mapM (args . f) xs
impureArgs :: ST s [x] -> Args s f a -> Args s (x -> f) a
impureArgs mxs args f = fmap concat . mapM (args . f) =<< mxs
mapArgs :: (a -> b) -> Args s f a -> Args s f b
mapArgs = fmap . fmap . fmap
composeArgs :: Args s a b -> Args s b c -> Args s a c
composeArgs ab bc a = fmap concat . mapM bc =<< ab a
type Pos = Int
data State s r e t a where
State :: !Pos
-> !(ProdR s r e t f)
-> !(Args s f b)
-> !(Conts s r e t b a)
-> State s r e t a
Final :: f -> Args s f a -> State s r e t a
data Cont s r e t a b where
Cont :: !Pos
-> !(Args s a b)
-> !(ProdR s r e t (b -> c))
-> !(Args s c d)
-> !(Conts s r e t d e')
-> Cont s r e t a e'
FinalCont :: Args s a c -> Cont s r e t a c
data Conts s r e t a c = Conts
{ conts :: !(STRef s [Cont s r e t a c])
, contsArgs :: !(STRef s (Maybe (STRef s (ST s [a]))))
}
newConts :: STRef s [Cont s r e t a c] -> ST s (Conts s r e t a c)
newConts r = Conts r <$> newSTRef Nothing
contraMapCont :: Args s b a -> Cont s r e t a c -> Cont s r e t b c
contraMapCont f (Cont cpos g p args cs) = Cont cpos (composeArgs f g) p args cs
contraMapCont f (FinalCont args) = FinalCont (composeArgs f args)
contToState :: ST s [a] -> Cont s r e t a c -> State s r e t c
contToState r (Cont cpos g p args cs) =
let mb = fmap concat . mapM g =<< r in
State cpos p (impureArgs mb args) cs
contToState r (FinalCont args) = Final id (impureArgs r args)
simplifyCont :: Conts s r e t b a -> ST s [Cont s r e t b a]
simplifyCont Conts {conts = cont} = readSTRef cont >>= go False
where
go !_ [Cont _ g (Pure f) args cont'] = do
ks' <- simplifyCont cont'
go True $ map (contraMapCont $ mapArgs f g `composeArgs` args) ks'
go True ks = do
writeSTRef cont ks
return ks
go False ks = return ks
grammar :: Grammar (Rule s r) e a -> ST s a
grammar g = case g of
RuleBind p k -> do
c <- newSTRef =<< newSTRef mempty
nr <- newSTRef Nothing
grammar $ k $ NonTerminal (Rule p nr c) $ Pure id
FixBind f k -> do
a <- mfix $ fmap grammar f
grammar $ k a
Return x -> return x
initialState :: ProdR s a e t a -> ST s (State s a e t a)
initialState p = State (1) p noArgs <$> (newConts =<< newSTRef [FinalCont noArgs])
data Report e i = Report
{ position :: Int
, expected :: [e]
, unconsumed :: i
} deriving (Eq, Ord, Read, Show)
data Result s e i a
= Ended (Report e i)
| Parsed (ST s [a]) Int i (ST s (Result s e i a))
deriving Functor
safeHead :: ListLike i t => i -> Maybe t
safeHead ts
| ListLike.null ts = Nothing
| otherwise = Just $ ListLike.head ts
safeTail :: ListLike i t => i -> i
safeTail ts
| ListLike.null ts = ts
| otherwise = ListLike.tail ts
data ParseEnv s e i t a = ParseEnv
{ results :: ![ST s [a]]
, next :: ![State s a e t a]
, reset :: !(ST s ())
, names :: ![e]
, pos :: !Pos
, input :: !i
}
emptyParseEnv :: i -> ParseEnv s e i t a
emptyParseEnv i = ParseEnv
{ results = mempty
, next = mempty
, reset = return ()
, names = mempty
, pos = 0
, input = i
}
parse :: ListLike i t
=> [State s a e t a]
-> ParseEnv s e i t a
-> ST s (Result s e i a)
parse [] env@ParseEnv {results = [], next = []} = do
reset env
return $ Ended Report
{ position = pos env
, expected = names env
, unconsumed = input env
}
parse [] env@ParseEnv {results = []} = do
reset env
parse (next env) (emptyParseEnv $ safeTail $ input env) {pos = pos env + 1}
parse [] env = do
reset env
return $ Parsed (concat <$> sequence (results env)) (pos env) (input env)
$ parse [] env {results = [], reset = return ()}
parse (st:ss) env = case st of
Final f args -> parse ss env {results = args f : results env}
State spos pr args scont -> case pr of
Terminal f p -> case safeHead $ input env of
Just t | f t -> parse ss env {next = State spos p (pureArg t args) scont
: next env}
_ -> parse ss env
NonTerminal r p -> do
rkref <- readSTRef $ ruleConts r
ks <- readSTRef rkref
writeSTRef rkref (Cont spos noArgs p args scont : ks)
nulls <- nullable r
let nullStates | null nulls = mempty
| otherwise = pure $ State spos p (pureArgs nulls args) scont
if null ks then do
st' <- State (pos env) (ruleProd r) noArgs <$> newConts rkref
parse (st' : nullStates ++ ss)
env {reset = resetConts r >> reset env}
else
parse (nullStates ++ ss) env
Pure a | spos /= pos env -> do
let argsRef = contsArgs scont
masref <- readSTRef argsRef
case masref of
Just asref -> do
modifySTRef asref (((++) <$> args a) <*>)
parse ss env
Nothing -> do
asref <- newSTRef $ args a
writeSTRef argsRef $ Just asref
ks <- simplifyCont scont
let kstates = map (contToState $ join $ readSTRef asref) ks
parse (kstates ++ ss)
env {reset = writeSTRef argsRef Nothing >> reset env}
| otherwise -> parse ss env
Alts as (Pure f) -> do
let args' = funArg f `composeArgs` args
sts = [State spos a args' scont | a <- as]
parse (sts ++ ss) env
Alts as p -> do
scont' <- newConts =<< newSTRef [Cont spos noArgs p args scont]
let sts = [State (1) a noArgs scont' | a <- as]
parse (sts ++ ss) env
Many p q -> do
c <- newSTRef =<< newSTRef mempty
nr <- newSTRef Nothing
let r = Rule (pure [] <|> (:) <$> p <*> NonTerminal r (Pure id)) nr c
st' = State spos (NonTerminal r q) args scont
parse (st' : ss) env
Named pr' n -> parse (State spos pr' args scont : ss)
env {names = n : names env}
parser :: ListLike i t
=> (forall r. Grammar r e (Prod r e t a))
-> i
-> ST s (Result s e i a)
parser g xs = do
s <- initialState =<< grammar g
parse [s] $ emptyParseEnv xs
allParses :: (forall s. ST s (Result s e i a)) -> ([(a, Int)], Report e i)
allParses p = runST $ p >>= go
where
go :: Result s e i a -> ST s ([(a, Int)], Report e i)
go r = case r of
Ended rep -> return ([], rep)
Parsed mas cpos _ k -> do
as <- mas
fmap (first (zip as (repeat cpos) ++)) $ go =<< k
fullParses :: ListLike i t => (forall s. ST s (Result s e i a)) -> ([a], Report e i)
fullParses p = runST $ p >>= go
where
go :: ListLike i t => Result s e i a -> ST s ([a], Report e i)
go r = case r of
Ended rep -> return ([], rep)
Parsed mas _ i k
| ListLike.null i -> do
as <- mas
fmap (first (as ++)) $ go =<< k
| otherwise -> go =<< k
report :: ListLike i t => (forall s. ST s (Result s e i a)) -> Report e i
report p = runST $ p >>= go
where
go :: ListLike i t => Result s e i a -> ST s (Report e i)
go r = case r of
Ended rep -> return rep
Parsed _ _ _ k -> go =<< k