module Text.GRead.Transformations.Group where
import Language.AbstractSyntax.TTTAS
import Text.GRead.Grammar
import Control.Arrow
newtype DT env1 env2
= DT { unDT :: forall a . DRef a env1 -> Ref a env2 }
mapDP2Prod :: DT env1 env2 -> DProd a env1
-> Prod a env2
mapDP2Prod _ (DEnd x) = End x
mapDP2Prod t (DSeq (DNont x) r)
= Seq (Nont (unDT t x))
(mapDP2Prod t r)
mapDP2Prod t (DSeq (DTerm x) r)
= Seq (Term x)
(mapDP2Prod t r)
type GTrafo = Trafo Unit Productions
dp2prod :: DProd a env -> GTrafo s (DT env s) (Prod a s)
dp2prod p = arr ( \env2s -> mapDP2Prod env2s p )
ld2nt :: (DRef a env, DProductions a env)
-> GTrafo s (DT env s) (DRef a s)
ld2nt (DRef (rnt,i),DPS lp)
= proc env2s ->
do ps <- sequenceA (map dp2prod lp) -< env2s
(PS nl) <- mkNxtLev -< env2s
r <- newSRef -< PS $ nl++ps
returnA -< DRef (r,i)
where
mkNxtLev = arr $ \t -> PS $
(if (i<10)
then [Seq (Nont $ unDT t $
DRef (rnt,i+1))
(End id)]
else [])
newtype ListDR a s = ListDR { unListDR :: [DRef a s] }
newtype DMapping o n = DMapping { unDMapping :: Env ListDR n o }
dmap2trans :: DMapping env s -> DT env s
dmap2trans (DMapping env)
= DT (\ (DRef (r,i))
-> case (lookupEnv r env) of
ListDR rs -> (plookup i rs))
plookup :: Int -> [DRef a s] -> Ref a s
plookup _ [] = error "Wrong Grammar!!"
plookup i ((DRef (r,p)):drs)
| i <= p = r
| otherwise = plookup i drs
group :: DGrammar a -> Grammar a
group gram
= let trafo = proc x ->
do (ListDR rs) <- (gGrammar gram) -< x
returnA -< plookup 0 rs
in case runTrafo trafo Unit undefined of
Result _ r grm -> Grammar r grm
gGrammar :: DGrammar a
-> GTrafo s t (ListDR a s)
gGrammar (DGrammar r gram) = proc _ ->
do rec let env_s = dmap2trans menv_s
menv_s <- gDGrams gram -< env_s
returnA -< lookupEnv r (unDMapping menv_s)
gDGrams :: Env DGram env env'
-> GTrafo s (DT env s) (DMapping env' s)
gDGrams Empty = arr (const (DMapping Empty))
gDGrams (Ext ps (DGG gram))
= proc env_s ->
do refs <- gGrammar gram -< env_s
ms <- gDGrams ps -< env_s
returnA -< DMapping $ Ext (unDMapping ms) refs
gDGrams (Ext ps (DGD (DLNontDefs nonts)))
= proc env_s ->
do r <- sequenceA (map ld2nt nonts) -< env_s
ms <- gDGrams ps -< env_s
returnA -< DMapping $ Ext (unDMapping ms) (ListDR r)