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

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))