module Text.Earley.Parser
( Report(..)
, Result(..)
, parser
, allParses
, fullParses
, report
) where
import Control.Applicative
import Control.Arrow
import Control.Monad
import Control.Monad.Fix
import Control.Monad.ST.Lazy
import Data.ListLike(ListLike)
import qualified Data.ListLike as ListLike
import Data.STRef.Lazy
import Text.Earley.Grammar
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 (Plus a b) = mappend <$> nullableProd a <*> nullableProd b
nullableProd (Many p q) = do
as <- nullableProd $ (:[]) <$> p <|> pure []
concat <$> mapM (\a -> nullableProd $ fmap ($ a) q) as
nullableProd Empty = return mempty
nullableProd (Named p _) = nullableProd p
type Args s f a = f -> ST s [a]
noArgs :: Args s a a
noArgs = return . pure
pureArg :: x -> Args s f a -> Args s (x -> f) a
pureArg x args = args . ($ x)
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]))))
}
contraMapCont :: Args s b a -> Cont s r e t a c -> Cont s r e t b c
contraMapCont f (Cont pos g p args cs) = Cont pos (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 pos g p args cs) =
let mb = fmap concat . mapM g =<< r in
State pos 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
<$> (Conts <$> newSTRef [FinalCont noArgs] <*> newSTRef Nothing)
data Report e i = Report
{ position :: Int
, expected :: [e]
, unconsumed :: i
} deriving 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)
uncons :: ListLike i t => i -> Maybe (t, i)
uncons i
| ListLike.null i = Nothing
| otherwise = Just (ListLike.head i, ListLike.tail i)
safeTail :: ListLike i t => i -> i
safeTail ts'
| ListLike.null ts' = ts'
| otherwise = ListLike.tail ts'
parse :: ListLike i t
=> [State s a e t a]
-> [ST s [a]]
-> [State s a e t a]
-> ST s ()
-> [e]
-> Pos
-> i
-> ST s (Result s e i a)
parse [] [] [] !reset names !pos !ts = do
reset
return $ Ended Report {position = pos, expected = names, unconsumed = ts}
parse [] [] !next !reset _ !pos !ts = do
reset
parse next [] [] (return ()) [] (pos + 1) $ safeTail ts
parse [] !results !next !reset names !pos !ts = do
reset
return $ Parsed (concat <$> sequence results) pos ts
$ parse [] [] next (return ()) names pos ts
parse (st:ss) !results !next !reset names !pos !ts = case st of
Final f args -> parse ss (args f : results) next reset names pos ts
State spos pr args scont -> case pr of
Terminal f p -> case uncons ts of
Just (t, _) | f t ->
parse ss results (State spos p (pureArg t args) scont : next) reset names pos ts
_ -> parse ss results next reset names pos ts
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 = [State spos p (pureArg a args) scont | a <- nulls]
if null ks then do
asref <- newSTRef Nothing
let st' = State pos (ruleProd r) noArgs (Conts rkref asref)
parse (st' : nullStates ++ ss)
results
next
((writeSTRef (ruleConts r) =<< newSTRef mempty) >> reset)
names
pos
ts
else
parse (nullStates ++ ss) results next reset names pos ts
Pure a | spos /= pos -> do
let argsRef = contsArgs scont
masref <- readSTRef argsRef
case masref of
Just asref -> do
modifySTRef asref (((++) <$> args a) <*>)
parse ss results next reset names pos ts
Nothing -> do
asref <- newSTRef (return mempty)
modifySTRef asref (((++) <$> args a) <*>)
writeSTRef argsRef $ Just asref
ks <- simplifyCont scont
let kstates = map (contToState $ join $ readSTRef asref) ks
parse (kstates ++ ss)
results
next
(writeSTRef argsRef Nothing >> reset)
names
pos
ts
| otherwise -> parse ss results next reset names pos ts
Plus p q -> parse (State spos p args scont : State spos q args scont : ss) results next reset names pos ts
Many p q -> do
scont' <- Conts <$> newSTRef [Cont spos noArgs (Many p ((\f as a -> f (a : as)) <$> q)) args scont]
<*> newSTRef Nothing
let st' = State pos p noArgs scont'
nst = State spos q (pureArg [] args) scont
parse (st' : nst : ss) results next reset names pos ts
Empty -> parse ss results next reset names pos ts
Named pr' n -> parse (State spos pr' args scont : ss) results next reset (n : names) pos ts
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] [] [] (return ()) [] 0 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 pos _ k -> do
as <- mas
fmap (first (zip as (repeat pos) ++)) $ 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