module Text.GRead.Transformations.LeftFact (leftfactoring) where
import Language.AbstractSyntax.TTTAS
import Text.GRead.Grammar
import Text.GRead.Transformations.GramTrafo
import Control.Arrow
import Data.Maybe
data AnySym env = forall x. AnySym (Symbol x env)
newtype BT env s = BT (Bool, T env s)
leftfactoring :: forall a. Grammar a -> Grammar a
leftfactoring (Grammar start productions)
= case runTrafo (lftrafo productions) Unit () of
Result _ (BT (b,T tt)) gram ->
let g = Grammar (tt start) gram
in if b then leftfactoring g
else g
lftrafo :: Env Productions env env
-> Trafo Unit Productions s () (BT env s)
lftrafo productions = proc _ ->
do rec let tenv_s = map2trans menv_s
(b,menv_s) <- (rules productions) -< tenv_s
returnA -< BT (b,tenv_s)
rules :: Env Productions env env'
-> Trafo Unit Productions s (T env s) (Bool,(Mapping env' s))
rules Empty
= proc _ ->
returnA -< (False, Mapping Empty)
rules (Ext ps (PS prods)) =
let rep = getrepeated prods
in proc tenv_s ->
do p <- app_rule rep prods -< tenv_s
r <- newSRef -< p
(bs,Mapping e) <- rules ps -< tenv_s
returnA -< ((length rep > 0) || bs, Mapping (Ext e r))
app_rule :: forall env a s. [AnySym env]
-> [Prod a env]
-> Trafo Unit Productions s (T env s) (Productions a s)
app_rule rep prods = initMap
( proc tenv_s ->
do pss <- sequenceA (map (rule rep) prods) -< tenv_s
returnA -< PS (concatMap unPS pss)
)
rule :: [AnySym env] -> Prod a env
-> GramTrafo env a s (T env s) (Productions a s)
rule _ (End a) = proc env2s ->
do returnA -< PS [ mapProd env2s (End a) ]
rule rep (Seq x beta)
| x `iselem` rep = proc env2s ->
do rinsert x -< (env2s, mapProd env2s beta)
| otherwise = proc env2s ->
do returnA -< PS [ mapProd env2s (Seq x beta) ]
rinsert :: forall env s a x. Symbol x env
-> GramTrafo env a s (T env s, Prod (x->a) s) (Productions a s)
rinsert x =
Trafo (
\(MapA_X m) -> case m x of
Nothing -> case proc (env2s,p) ->
do r <- newNontR x -< PS [p]
addprod x -< (env2s,r)
of Trafo step -> step (MapA_X m)
Just r -> TrafoE (MapA_X m)
(\(_,p) t e u ->
( PS []
, t
, updateEnv (\(PS ps)
-> PS (p:ps))
r e
, u
)
)
)
addprod :: Symbol x env -> GramTrafo env a s (T env s, Ref (x -> a) s)
(Productions a s)
addprod (Term x) = proc (_, a__x) ->
do returnA -< PS [ Term x .*. Nont a__x .*. End ($)]
addprod (Nont r) = proc (env2s,a__x) ->
do returnA -< PS [ Nont (unT env2s r) .*. Nont a__x
.*. End ($)]
getrepeated :: [Prod a env] -> [AnySym env]
getrepeated prods = repeated $ mapMaybe head' prods
where head' (End _ ) = Nothing
head' (Seq x _) = Just (AnySym x)
repeated [] = []
repeated (ax@(AnySym x):xs)
| x `iselem` xs = ax : repeated (filter (noteqAny ax) xs)
| otherwise = repeated xs
noteqAny (AnySym x) (AnySym y) = (aux $ matchSym x y)
aux :: Maybe (Equal a b) -> Bool
aux (Just Eq) = False
aux Nothing = True
iselem :: Symbol t env -> [AnySym env] -> Bool
iselem _ [] = False
iselem x ((AnySym y):ys) = case (matchSym x y) of
(Just Eq) -> True
Nothing -> iselem x ys