{-# LANGUAGE  RankNTypes, Arrows, DoRec #-} 

module Language.Grammars.Transformations.RemoveFix (removeFix) where


import Language.AbstractSyntax.TTTAS
import Language.Grammars.Grammar
import Language.Grammars.Transformations.GramTrafo

import Control.Arrow

removeFix :: forall a . Grammar a -> Grammar a
removeFix (Grammar start productions)
      = case runTrafo (remfixtrafo productions) Unit () of
            Result _ (T tt) gram -> 
                 Grammar (tt start) gram

remfixtrafo :: GramEnv env env 
        -> Trafo Unit (Productions TL) s () (T env s)
remfixtrafo productions = proc _ ->
            do   rec  let tenv_s = map2trans menv_s
                      menv_s <- (remfixProds productions) -< tenv_s
                 returnA -< tenv_s


remfixProds  ::  GramEnv env env' 
             ->  Trafo  Unit (Productions TL) s (T env s) 
                                                (Mapping env' s)
remfixProds Empty          
     = proc _ ->
        returnA -< Mapping Empty  

remfixProds (Ext p (PS prods)) 
     = proc tenv_s ->
        do  ps <- sequenceA  (map  remfixProd prods) -< tenv_s 
            r  <- newSRef -< PS ps   
            Mapping e <- remfixProds p -< tenv_s
            returnA -< Mapping (Ext e r)



remfixProd  :: Prod l a env 
            -> Trafo Unit (Productions TL) s (T env s) (Prod l a s)

remfixProd (Fix (PS ps)) 
     = proc tenv_s ->
        do  rec  ps' <- sequenceA (map remfixProd ps) -< tenv_s
                 r   <- newSRef -<  PS (map (remVar r) ps')     
            returnA -< (Sym $ Nont r)

remfixProd (Star f g) 
     = proc tenv_s ->
        do  f' <- remfixProd f -< tenv_s
            g' <- remfixProd g -< tenv_s
            returnA -< Star f' g'

remfixProd (FlipStar f g) 
     = proc tenv_s ->
        do  f' <- remfixProd f -< tenv_s
            g' <- remfixProd g -< tenv_s
            returnA -< FlipStar f' g'

remfixProd p 
     = proc tenv_s ->
        do  returnA -< mapProd tenv_s p



remVar  :: Ref b env -> Prod (FL b) a env -> Prod TL a env
remVar _ (Sym s)             = Sym s 
remVar _ (Pure x)            = Pure x
remVar r  (Star f g)         = Star (remVar r f) (remVar r g)
remVar r  (FlipStar f g)     = FlipStar (remVar r f) (remVar r g)
remVar r  Var                = Sym (Nont r) 

remVar _ (Fix _)             = error "RemoveFix(1): error in the transformation!!!"