LeftFact.hs

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

module Text.GRead.Transformations.LeftFact (leftfactoring) where

import Language.TTTAS
import Text.GRead.Grammar
import Text.GRead.Transformations.GramTrafo
import Control.Arrow
import Data.Maybe



--list of repeated symbols (with hidden type)
data AnySym env = forall x. AnySym (Symbol x env)

newtype BT env s = BT (Bool, T env s)

-- The 'leftfactoring' function makes a feed-back loop to apply the 
-- transformation to the Grammar.
-- If the transformation has produced new nonterminals (repeated initial
-- symbols have been found) the 'leftfactoring' function is called again.
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 _ ->
            mdo  let tenv_s = map2trans menv_s
                 (b,menv_s) <- (rules productions) -< tenv_s
                 returnA -< BT (b,tenv_s)


-- The function 'rules' is defined by induction over the original Grammar. 
-- Applies the "transformation rule" for each nonterminal (and
-- its corresponding productions) of the Grammar.
-- First of all, the list of "repeated initial symbols" in the productions
-- of a nonterminal is found.
-- Having this list, the rule is applied to the productions.
-- The nonterminal is added to the new Grammar, with the productions
-- generated by the rule.
-- The output of the Trafo is compound by a boolean indicating if repeated
-- symbols were found, and the Mapping from the positions in the new Grammar
-- for each nonterminal of the old Grammar.
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)
          )

-- If the first symbol of the production is in the list of "repeated
-- initial symbols", the transformation generated by 'rinstert'
-- is called with input the rest of the production. So, a new nonterminal
-- A_Rest_X is generated (if necessary) and the rest (beta) of the production
-- is stored as a production of it.
-- In other case the production (with its references mapped to the
-- to the new Grammar) is returned. 
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) ]


-- Insertion of a new production into one "rest" nonterminal.
-- If the symbol 'x' is in the MapA_X the nonterminal was already
-- added, so we obtain the reference of the nonterminal and add the new
-- production.
-- Otherwise, we have to create the new nonterminal (newNontR x).
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 ($)]


-- Get the list of symbols that are repeated as "first symbol" in the list
-- of productions.
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