module Text.GRead.Transformations.LeftCorner (leftcorner) where
import Language.AbstractSyntax.TTTAS
import Text.GRead.Grammar
import Text.GRead.Transformations.GramTrafo
import Control.Arrow
leftcorner :: forall a . Grammar a -> Grammar a
leftcorner (Grammar start productions)
= case runTrafo (lctrafo productions) Unit () of
Result _ (T tt) gram ->
Grammar (tt start) gram
lctrafo :: Env Productions env env
-> Trafo Unit Productions s () (T env s)
lctrafo productions = proc _ ->
do rec let tenv_s = map2trans menv_s
menv_s <- (rules1 productions productions) -< tenv_s
returnA -< tenv_s
rules1 :: Env Productions env env
-> Env Productions env env'
-> Trafo Unit Productions s (T env s)
(Mapping env' s)
rules1 _ Empty
= proc _ ->
returnA -< Mapping Empty
rules1 productions (Ext ps (PS prods))
= proc tenv_s ->
do p <- app_rule1 productions prods -< tenv_s
r <- newSRef -< p
Mapping e <- rules1 productions ps -< tenv_s
returnA -< Mapping (Ext e r)
app_rule1 :: forall env a s. Env Productions env env
-> [Prod a env]
-> Trafo Unit Productions s (T env s) (Productions a s)
app_rule1 productions prods = initMap
( proc tenv_s ->
do pss <- sequenceA (map (rule1 productions) prods) -< tenv_s
returnA -< PS (concatMap unPS pss)
)
rule1 :: Env Productions env env -> Prod a env
-> GramTrafo env a s (T env s) (Productions a s)
rule1 gram (Seq x beta)
= proc tenv_s ->
do insert gram x -< (tenv_s, mapProd tenv_s beta)
rule1 _ _ = error "Error: the impossible haṕpened in LeftCorner::rule1"
rule2 :: Env Productions env env
-> Symbol x env
-> GramTrafo env a s (T env s, Ref (x -> a) s)
(Productions a s)
rule2 _ (Term a)
= proc (_, a_x) ->
do returnA -< PS [rule2a a a_x]
rule2 gram (Nont b)
= case lookupEnv b gram of
PS ps -> proc (tenv_s, a_x) ->
do pss <- sequenceA
(map (rule2b gram) ps) -< (tenv_s, a_x)
returnA -< PS (concatMap unPS pss)
rule2a :: Token -> Ref (Token -> a) s -> Prod a s
rule2a a refA_a
= Term a .*. Nont refA_a .*. End ($)
rule2b :: Env Productions env env
-> Prod b env
-> GramTrafo env a s (T env s, Ref (b -> a) s)
(Productions a s)
rule2b gram (Seq x beta)
= proc (tenv_s, a_b) ->
do insert gram x -< (tenv_s, append (flip (.))
(mapProd tenv_s beta)
(Nont a_b))
rule2b _ _ = error "Error: the impossible haṕpened in LeftCorner::rule2b"
insert :: forall env s a x
. Env Productions env env
-> Symbol x env
-> GramTrafo env a s (T env s, Prod (x->a) s)
(Productions a s)
insert gram x =
Trafo (
\(MapA_X m) -> case m x of
Just r -> extendA_X (MapA_X m) r
Nothing -> let Trafo step = insertNewA_X
in step (MapA_X m)
)
where
insertNewA_X = proc (tenv_s,p) ->
do r <- newNontR x -< PS [p]
rule2 gram x -< (tenv_s,r)
extendA_X :: m env2-> Ref (x->a) env2-> TrafoE m Productions s env2 (t, Prod (x->a) s) (Productions a env)
extendA_X m r = fmap (const $ PS []) $
updateSRef m r (\(_,p) (PS ps) -> PS (p:ps))