{-# OPTIONS -fglasgow-exts -XArrows #-}

module Text.GRead.Transformations.Group where

import Language.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 _ ->
        mdo 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)