SyntaxMacros 0.2 → 1.0

raw patch · 18 files changed

+950/−513 lines, 18 filesdep +HListbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: HList

API changes (from Hackage documentation)

Files

• SyntaxMacros.cabal +23/−20
• examples/LangDef.hs +47/−17
• examples/LangExt.hs +128/−36
• examples/LangSem.hs +7/−7
• examples/Main.hs +18/−6
• examples/README.txt +0/−9
• examples/prog2.src +1/−1
• examples/prog3.src +1/−0
• examples/test +0/−5
• pru.hs +0/−11
• src/Language/Grammars/.Grammar.hs.swp binary
• src/Language/Grammars/Grammar.hs +200/−67
• src/Language/Grammars/SyntaxMacros.hs +88/−76
• src/Language/Grammars/Transformations/GramTrafo.hs +46/−35
• src/Language/Grammars/Transformations/LeftCorner.hs +159/−65
• src/Language/Grammars/Transformations/LeftFact.hs +0/−158
• src/Language/Grammars/Transformations/RemoveEmpties.hs +154/−0
• src/Language/Grammars/Transformations/RemoveFix.hs +78/−0

@@ -1,5 +1,6 @@ name:               SyntaxMacros -version:            0.2+version:            1.0+cabal-version:      >= 1.2.3   license:            LGPL license-file:       COPYRIGHT maintainer:         Marcos Viera <mviera@fing.edu.uy>@@ -10,23 +11,25 @@ category:           Development  stability:          Experimental copyright:          Universiteit Utrecht-build-depends:      base>=4 && <5, haskell98, template-haskell>=2.4.0.1, TTTAS>=0.4.0, AspectAG>=0.2,-                    uulib>=0.9.12, containers>=0.3-cabal-version:      >= 1.2.3  -exposed-modules:    Language.Grammars.Grammar, -                    Language.Grammars.SyntaxMacros, -                    Language.Grammars.SyntaxMacros.Scanner-other-modules:      Language.Grammars.SyntaxMacros.Machine, -                    Language.Grammars.SyntaxMacros.Token, -                    Language.Grammars.SyntaxMacros.TokenParser, -                    Language.Grammars.SyntaxMacros.ScanUtils, -                    Language.Grammars.SyntaxMacros.Utils, -                    Language.Grammars.Transformations.GramTrafo,-                    Language.Grammars.Transformations.LeftCorner,-                    Language.Grammars.Transformations.LeftFact-extensions:         EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies,-                    MultiParamTypeClasses, RankNTypes, ScopedTypeVariables,-                    TypeSynonymInstances, UndecidableInstances, GADTs-hs-source-dirs:     src extra-source-files: README, LICENSE-LGPL -ghc-options:        -Wall+library+        build-depends:      base>=4 && <5, haskell98, template-haskell>=2.4.0.1, TTTAS>=0.4.0, AspectAG>=0.2,+                            uulib>=0.9.12, containers>=0.3, HList>=0.2+        exposed-modules:    Language.Grammars.Grammar, +                            Language.Grammars.SyntaxMacros, +                            Language.Grammars.SyntaxMacros.Scanner+        other-modules:      Language.Grammars.SyntaxMacros.Machine, +                            Language.Grammars.SyntaxMacros.Token, +                            Language.Grammars.SyntaxMacros.TokenParser, +                            Language.Grammars.SyntaxMacros.ScanUtils, +                            Language.Grammars.SyntaxMacros.Utils, +                            Language.Grammars.Transformations.GramTrafo,+                            Language.Grammars.Transformations.RemoveEmpties,+                            Language.Grammars.Transformations.RemoveFix,+                            Language.Grammars.Transformations.LeftCorner+        extensions:         EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies,+                            MultiParamTypeClasses, RankNTypes, ScopedTypeVariables,+                           TypeSynonymInstances, UndecidableInstances, GADTs+        hs-source-dirs:     src+        ghc-options:        -Wall+

@@ -1,13 +1,13 @@-{-# LANGUAGE  Arrows, DoRec, EmptyDataDecls, FlexibleContexts #-}+{-# OPTIONS -fcontext-stack=100 #-} +{-# LANGUAGE  Arrows, DoRec #-}+ module LangDef where  import qualified Data.Set as Set  import Control.Arrow -import UU.Pretty- import Language.Grammars.SyntaxMacros import Language.Grammars.Grammar @@ -16,28 +16,57 @@ import LangSem import Utils +import Control.Applicative +import Data.HList++import UU.Pretty.Basic++ prds = proc () -> do-         rec  root    <- addNT -<  [  prd (`semAGItf` ()) $ ch_expr<=>exp  <.> prdEnd  ]  -              exp     <- addNT -<  [  prd semLet $ trm "let" <.> ch_lnm<=>var  <.>  trm "=" <.> ch_val<=>exp <.> -                                                   trm "in"  <.> ch_body<=>exp <.> prdEnd   -                                   ,  prd semAdd $ ch_ae1<=>term <.> trm "+"  <.> ch_ae2<=>exp <.> prdEnd-                                   ,  prdId term  ]-                                 -              term    <- addNT -<  [  prd semMul $ ch_me1<=>term <.> trm "*"  <.> ch_me2<=>factor <.> prdEnd-                                   ,  prdId factor ]+         rec     root    <- addNT -<  (iI (`semAGItf` emptyRecord) (ch_expr <=> exp) Ii)+                 exp     <- addNT -<  (iI semLet "let" (ch_lnm   <=> var)  "=" (ch_val <=> exp) "in" (ch_body <=> exp) Ii)+                                      <|>+                                      (iI semAdd (ch_ae1  <=>  exp) "+" (ch_ae2 <=> term) Ii)+                                      <|>+                                      ntPrd term+                 term    <- addNT -<  (iI semMul (ch_me1  <=>  term)  "*"  (ch_me2 <=> factor) Ii)+                                      <|>+                                      ntPrd factor -              factor  <- addNT -<  [  prd semCst $ ch_cv<=>int  <.> prdEnd -                                   ,  prd semVar $ ch_vnm<=>var <.> prdEnd ]+                 factor  <- addNT -<  (iI semCst (ch_cv <=> int) Ii)+                                      <|> +                                      (iI semVar (ch_vnm <=> var) Ii) -         exportNTs -< Export root $   ntExp     ^=  exp     ^| -                                      ntTerm    ^=  term    ^|-                                      ntFactor  ^=  factor  ^|  -                                      ntNil +         exportNTs -< exportList root  $   export ntExp     exp +                                       .   export ntTerm    term +                                       .   export ntFactor  factor  + +{-+-- another possible version+prds = proc () -> do +         rec     root    <- addNT -<  (`semAGItf` emptyRecord) <$> ch_expr <=> exp+                 exp     <- addNT -<  semLet <$  tr "let" <*>  ch_lnm   <=> var  <*  tr "=" <*> ch_val <=> exp <* tr "in"  <*>  ch_body <=> exp+                                      <|>+                                      semAdd <$>  ch_ae1  <=>  exp   <* tr "+"  <*>  ch_ae2 <=> term+                                      <|>+                                      ntPrd term+                 term    <- addNT -<  semMul <$>  ch_me1  <=>  term  <* tr "*"  <*>  ch_me2 <=> factor+                                      <|>+                                      ntPrd factor +                 factor  <- addNT -<  semCst <$>  ch_cv <=> int+                                      <|> +                                      semVar <$>  ch_vnm <=> var +         exportNTs -< exportList root  $   export ntExp     exp +                                       .   export ntTerm    term +                                       .   export ntFactor  factor  ++-}+ gramOpts :: ScanOpts gramOpts   =  defaultScanOpts@@ -45,4 +74,5 @@         ,   scoSpecChars        =   Set.fromList "=+*"         ,   scoDollarIdent      =   True         }+  

@@ -1,4 +1,6 @@-{-# LANGUAGE  Arrows, DoRec, EmptyDataDecls, FlexibleContexts, TemplateHaskell, NoMonomorphismRestriction #-}+{-# OPTIONS -fcontext-stack=100 #-}+{-# LANGUAGE  Arrows, DoRec, EmptyDataDecls, FlexibleContexts, TemplateHaskell, NoMonomorphismRestriction,+    RankNTypes #-}  module LangExt where @@ -17,41 +19,64 @@ import LangSem import Utils +import Control.Applicative+ import Data.HList.Label4 import Data.HList.TypeEqGeneric1 import Data.HList.TypeCastGeneric1  + -- modifications of the semantics synM = synmodM inhM = inhmodM -$(chLabel "se" ''T_Expr) -sppSq = synM spp $ do me1 <- at ch_me1 -                      return $ "square " >|< (me1 # spp)   +--Syntax Macro 1 --------------------------------------------------------------  -semSq r = knit (sppSq `ext` aspMul)  -               (ch_me1 .=. (r # ch_se) .*. ch_me2 .=. (r # ch_se) .*. emptyRecord)+type AttExpr =  Record (HCons (LVPair (Proxy Att_ienv) [(String,Int)]) HNil)+                -> Record (HCons (LVPair (Proxy Att_spp) PP_Doc)+                          (HCons (LVPair (Proxy Att_sval) Int) HNil))  -$(chLabels ["pe1","pe2"] ''T_Expr)+--Square+$(chLabel "se" ''T_Expr) -sppPyth  = synM spp  $ do  ae1 <- at ch_ae1-                           ae2 <- at ch_ae2 -                           return $ "pyth " >|< (ae1 # spp) >|< " "-                                            >|< (ae2 # spp)   +sppSq = synM spp $ do me1 <- at ch_se +                      return $ "square" >#< (me1 # spp)    -svalPyth = synM sval $ do  ae1 <- at ch_ae1-                           ae2 <- at ch_ae2-                           return  $ (\p1 p2 -> p1 * p1 + p2 * p2 )(ae1 # sval) (ae2 # sval)     +se2m r = (ch_me1 .=. (r # ch_se) .*. ch_me2 .=. (r # ch_se) .*. emptyRecord)+m2se r = (ch_se .=. (r # ch_me1) .*. emptyRecord) -semPyth r = knit (sppPyth `ext` svalPyth `ext` aspAdd) -                 (ch_ae1 .=. (r # ch_pe1) .*. ch_ae2 .=. (r # ch_pe2) .*. emptyRecord)+aspSq = sppSq `ext` (adapt aspMul se2m se2m m2se)+semSq = \s -> knit aspSq (s .*. emptyRecord)    +--Pyth+$(chLabels ["pe1","pe2"] ''T_Expr) +sppSq' = synM spp $ do liftM (# spp) (at ch_se) +aspSq' = sppSq' `ext` aspSq  +sppPyth  = synM spp  $ do  pe1 <- at ch_pe1+                           pe2 <- at ch_pe2 +                           return $ "pyth" >#< (pe1 # spp) >#< (pe2 # spp)   ++aspAdd' =  graft  (graft  aspAdd+                          (ch_ae2 .=. ch_ae2 .*. hNil)+                          ch_ae1 +                          aspSq' +                          (ch_se .=. ch_pe1 .*. hNil))+                  (ch_pe1 .=. ch_pe1 .*. hNil)+                  ch_ae2+                  aspSq' +                  (ch_se .=. ch_pe2 .*. hNil)++aspPyth    = sppPyth `ext` aspAdd'+semPyth = \p1 p2 -> knit  aspPyth (p1 .*. p2 .*. emptyRecord)  +                ++--Parenthesis $(chLabel "pe" ''T_Expr)  sppPar  = syn spp  $ do  pe <- at ch_pe@@ -59,44 +84,111 @@ svalPar = syn sval $ do  liftM (# sval) (at ch_pe) ienvPar = copy ienv exprNT +aspPar = sppPar `ext` ienvPar `ext` svalPar    -semPar = knit (sppPar `ext` ienvPar `ext` svalPar)+semPar = \e -> knit aspPar (e .*. emptyRecord)  +--Substitution sppSubst = synM spp $ do  lnm   <- at ch_lnm                           val   <- at ch_val                           body  <- at ch_body                           return $ (body # spp) >|< "[" >|< (pp lnm)  >|< " | " >|< (val # spp) >|< "]"  -semSubst r = knit (sppSubst `ext` aspLet) r+semSubst = \l v b -> knit (sppSubst `ext` aspLet) (l .*. v .*. b .*. emptyRecord)   ---extended grammar (syntax macro)  -type AttExpr =  Record (HCons (LVPair (Proxy Att_ienv) [(String,Int)]) HNil)-                -> Record (HCons (LVPair (Proxy Att_spp) PP_Doc)-                          (HCons (LVPair (Proxy Att_sval) Int) HNil))+--Grammar Extension+prds'  ::  ( NTRecord (nts env) +           , GetNT NTExp    (nts env)  (Symbol AttExpr TNonT env)+           , GetNT NTTerm   (nts env)  (Symbol AttExpr TNonT env)+           , GetNT NTFactor (nts env)  (Symbol AttExpr TNonT env)) +       =>    SyntaxMacro env start nts start nts+prds' = proc imported -> do+         let exp     = getNT ntExp     imported+         let term    = getNT ntTerm    imported+         let factor  = getNT ntFactor  imported +         addProds   -<  (exp,     ( iI semSubst  (ch_body <=> exp) "[" (ch_lnm <=> var) "|" (ch_val <=> exp) "]" Ii)) -prds'  ::    ( NTRecord (nts env) -             , GetNT NTExp    (nts env)  (Symbol AttExpr TNonT env)-             , GetNT NTFactor (nts env)  (Symbol AttExpr TNonT env)) -       =>    SyntaxMacro env (Export start nts) (Export start nts)-prds' = proc (Export root nts) -> do-         let exp     = getNT ntExp     nts-         addProds   -<  (exp,     [  prd semSq    $ trm "square"  <.> ch_se<=>exp <.> prdEnd-                                  ,  prd semPyth  $ trm "pyth" <.> ch_pe1<=>exp <.> ch_pe2<=>exp <.> prdEnd-                                  ,  prd semSubst $ ch_body<=>exp <.> trm "[" <.> ch_lnm<=>var <.> -                                                    trm "|" <.> ch_val<=>exp <.> trm "]"  <.> prdEnd    ])+         addProds   -<  (term,    ( iI semSq     "square"  (ch_se  <=> factor) Ii) <|>+                                  ( iI semPyth   "pyth"    (ch_pe1 <=> factor) (ch_pe2 <=> factor) Ii))  --         let factor  = getNT ntFactor  nts-         addProds   -<  (factor,  [  prd semPar $ trm "(" <.> ch_pe<=>exp <.> trm ")" <.>  prdEnd  ])+         addProds   -<  (factor,  ( iI semPar    "(" (ch_pe <=> exp) ")" Ii )    )          -         exportNTs  -< (Export root nts)+         exportNTs  -< imported ++ gramOpts' gramOpts = gramOpts `extKeywordsTxt` [ "square", "pyth" ] `extSpecChars` "()[|]"++++--Syntax Macro 2 --------------------------------------------------------------++--Double+$(chLabel "de" ''T_Expr)++aspTwo = fixCst aspCst ch_cv 2++aspMul' =  graft  aspMul+                  (ch_me2 .=. ch_de .*. hNil) +                  ch_me1+                  aspTwo+                  hNil ++sppDb = synM spp $ do de <- at ch_de +                      return $ "double" >#< (de # spp)   ++aspDb = sppDb `ext` aspMul'+                +semDb = \d -> knit aspDb (d .*. emptyRecord)++           +++--AddMul+$(chLabels ["am1","am2","am3"] ''T_Expr)+++sppAddMul = synM spp $ do  am1 <- at ch_am1 +                           am2 <- at ch_am2 +                           am3 <- at ch_am3 +                           return $ "addmul" >#< (am1 # spp) >#< (am2 # spp) >#< (am3 # spp)  ++aspAddMul = ext sppAddMul $  graft  aspAdd+                                    (ch_ae1 .=. ch_am1 .*. hNil)+                                    ch_ae2 +                                    aspMul+                                    (ch_me1 .=. ch_am2 .*. ch_me2 .=. ch_am3 .*. hNil)+ +semAddMul = \p1 p2 p3 -> knit aspAddMul (p1 .*. p2 .*. p3 .*. emptyRecord)+                          +++--Grammar Extension++prds''  ::    ( NTRecord (nts env) +              , GetNT NTTerm   (nts env)  (Symbol AttExpr TNonT env)+              , GetNT NTFactor (nts env)  (Symbol AttExpr TNonT env)) +       =>    SyntaxMacro env start nts start nts+prds'' = proc imported -> do+         let term    = getNT ntTerm    imported+         let factor  = getNT ntFactor  imported+++         addProds   -<  (term,     (iI semDb      "double"  (ch_de   <=> factor) Ii) <|>+                                   (iI semAddMul  "addmul"  (ch_am1  <=> factor) (ch_am2  <=> factor) (ch_am3  <=> factor) Ii))++         +         exportNTs  -< imported++++gramOpts'' gramOpts = gramOpts `extKeywordsTxt` [ "double", "addmul" ] `extSpecChars` "()[|]"+   

@@ -23,7 +23,7 @@              |  Mul {me1 :: T_Expr, me2 :: T_Expr}              |  Add {ae1 :: T_Expr, ae2 :: T_Expr}              |  Let {lnm :: String, val :: T_Expr, body :: T_Expr}-  deriving Show+          deriving Show   @@ -91,11 +91,11 @@ aspLet   = sppLet   `ext` ienvLet   `ext` svalLet  -semAGItf  r  = knit aspAGItf r -semCst r     = knit aspCst  r-semVar r     = knit aspVar  r-semMul r     = knit aspMul  r-semAdd r     = knit aspAdd  r-semLet      = knit aspLet  +semAGItf  = \r -> knit aspAGItf (r .*. emptyRecord)   +semCst    = \c -> knit aspCst (c .*. emptyRecord)  +semVar    = \v -> knit aspVar (v .*. emptyRecord)  +semMul    = \m1 m2 -> knit aspMul  (m1 .*. m2 .*. emptyRecord)  +semAdd    = \a1 a2 -> knit aspAdd  (a1 .*. a2 .*. emptyRecord)+semLet    = \l v b -> knit aspLet  (l .*. v .*. b .*. emptyRecord)  

@@ -6,8 +6,8 @@  import LangDef import LangSem-import LangExt +import LangExt  import Language.Grammars.SyntaxMacros import Language.Grammars.SyntaxMacros.Scanner@@ -19,14 +19,18 @@  test1 = do         tokens <- scanFile gramOpts "prog.src"-        let (Ok res) = (parse . compile ) gram tokens-        print $ res # spp-        print $ res # sval+        let r = (parse . compile ) gram tokens +        case ( parse . compile ) gram tokens of+           (Ok res) -> do print $ res # spp+                          print $ res # sval+           (Rep _ err) -> print err  -gram' = closeGram (extendGram prds prds')  ++gram' = closeGram (prds <++> prds') + test2 = do         tokens <- scanFile (gramOpts' gramOpts) "prog2.src"         case ( parse . compile ) gram' tokens of@@ -34,7 +38,15 @@                           print $ res # sval            (Rep _ err) -> print err +gram'' = closeGram (prds <++> prds' <++> prds'')  -main = test1 >> test2 +test3 = do+        tokens <- scanFile ((gramOpts'' . gramOpts') gramOpts) "prog3.src"+        case ( parse . compile ) gram'' tokens of+           (Ok res) -> do print $ res # spp+                          print $ res # sval+           (Rep _ err) -> print err ++main = test1 >> test2 >> test3 

@@ -1,9 +0,0 @@-Modules of the example:--- LangSem.hs   semantic functions of the original language-- LangDef. hs  definition of the grammar of the original language-- LangExt.hs   extension (grammar + semantics) of the language-- Utils.hs     some definitions shared by LangDef and LangExt-- prog.src     program with the syntax of the original language-- prog2.src    program with the extended syntax-- Main.hs      creates and executes compilers of the original and extended languages

@@ -1,1 +1,1 @@-let letter= pyth ( 2 + 1) 3 in ( (x + 1) [x | 10]) * (letter + square 4)+let letter= pyth ( 2 + 1) 3 in ( (x + 1) [x | 10]) * (letter + square 2)

@@ -0,0 +1,1 @@+let letter= pyth ( 2 + 1) 3 in ( (x + 1) [x | 10]) * (letter + addmul 2 3 4 + square ( double 3 ))

@@ -1,5 +0,0 @@-cd ..-runghc Setup.hs build-sudo runghc Setup.hs install-cd examples-ghci Main

@@ -1,11 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}--class A a b | a -> b where- fa :: a -> b---instance A Bool Bool where- fa b = b--instance A a a where- fa a = a + 1

binary file changed (absent → 24576 bytes)

@@ -1,26 +1,46 @@-{-# LANGUAGE ExistentialQuantification, GADTs, EmptyDataDecls, -    MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances  #-}+{-# LANGUAGE ExistentialQuantification, GADTs, EmptyDataDecls,+    MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}  module Language.Grammars.Grammar where  import Language.AbstractSyntax.TTTAS-import Language.Grammars.AspectAG hiding (append)+import Data.HList +import Control.Applicative+import Unsafe.Coerce ++-------------------------------------------+-- GRAMMAR REPRESENTATION+-------------------------------------------++data TL+data FL a++ data Grammar a     = forall env . Grammar  (Ref a env)  -                          (Env Productions env env)+                          (GramEnv env env) -newtype Productions a env -  = PS {unPS :: [Prod a env]}+type GramEnv = Env (Productions TL) -data Prod a env where-      Seq   ::  Symbol    b  t     env  ->  Prod   (b -> a)  env  -                                        ->  Prod   a         env-      End   ::  a                       ->  Prod   a         env+newtype Productions l a env +  = PS {unPS :: [Prod l a env]} -data DTerm = DTerm+data Prod l a env where+      Star      ::  Prod l (a->b) env -> Prod l a      env ->  Prod l b  env+      FlipStar  ::  Prod l a      env -> Prod l (a->b) env ->  Prod l b  env+      Sym       ::  Symbol a t env                         ->  Prod l a  env+      Pure      ::  a                                      ->  Prod l a  env +      Fix       ::  Productions (FL a) a env               ->  Prod l      a  env+      Var       ::                                             Prod (FL a) a  env ++-- I tried with HOAS, but it is more restrictive+--      Fix       ::  (forall s. Prod a s -> Productions a s)  -> Prod a env ++type DTerm = String+ data TTerm data TNonT data TAttT@@ -30,13 +50,14 @@    Nont    :: Ref a env ->  Symbol  a        TNonT   env   -- attributed terminals-  NontInt   ::             Symbol  Int      TAttT   env-  NontChar  ::             Symbol  Char     TAttT   env-  NontVarid ::             Symbol  String   TAttT   env-  NontConid ::             Symbol  String   TAttT   env-  NontOp    ::             Symbol  String   TAttT   env +  TermInt   ::             Symbol  Int      TAttT   env+  TermChar  ::             Symbol  Char     TAttT   env+  TermVarid ::             Symbol  String   TAttT   env+  TermConid ::             Symbol  String   TAttT   env+  TermOp    ::             Symbol  String   TAttT   env    --- TODO: the rest of EnumValToken + getRefNT :: Symbol a TNonT env -> Ref a env getRefNT (Nont ref) = ref @@ -49,82 +70,194 @@           ->  Maybe (Equal (a,t1) (b,t2)) matchSym (Nont x)   (Nont y)             = pairEq $ match x y matchSym (Term x)   (Term y) | x == y    = Just Eq-matchSym NontInt    NontInt              = Just Eq-matchSym NontVarid  NontVarid            = Just Eq-matchSym NontConid  NontConid            = Just Eq-matchSym NontOp     NontOp               = Just Eq+matchSym TermInt    TermInt              = Just Eq+matchSym TermVarid  TermVarid            = Just Eq+matchSym TermConid  TermConid            = Just Eq+matchSym TermOp     TermOp               = Just Eq matchSym _          _                    = Nothing  -append  :: (a -> b -> c) -> Prod a env -> Symbol b t env -        -> Prod c env-append g (End f     )  s  =  Seq s  (End (g f))-append g (Seq t ts  )  s  -  =  Seq t (append  (\b c d -> g (b d) c) ts s)-- int   ::  Symbol Int     TAttT  env char  ::  Symbol Char    TAttT  env var   ::  Symbol String  TAttT  env con   ::  Symbol String  TAttT  env op    ::  Symbol String  TAttT  env -int   =  NontInt-char  =  NontChar-var   =  NontVarid-con   =  NontConid-op    =  NontOp+int   =  TermInt+char  =  TermChar+var   =  TermVarid+con   =  TermConid+op    =  TermOp  -data EP a b env = EP a (b env)+------------------------+-- APPLICATIVE INTERFACE+++newtype ListProd l env a = PP { unPP :: [ Prod l a env ] }+++prod :: ListProd l env a -> Productions l a env+prod (PP ps) = PS ps++sym  ::  Symbol a  t  env -> ListProd l env a+sym  s = PP [ Sym $ s ]++nt :: Symbol a  TNonT  env -> ListProd l env a+nt s = sym s++ntPrd :: Symbol a  TNonT  env -> ListProd l env a+ntPrd s =  id <$> nt s+ ++tr ::  String -> ListProd l env DTerm+tr s = PP [ Sym $ Term s ]+++varPrd   ::  ListProd (FL a) env a+varPrd    = PP [ Var ]+fixPrd  ::  ListProd (FL a) env a -> ListProd l env a+fixPrd p  = PP [ (Fix . prod) p ]+++instance Functor (ListProd l env) where+ fmap f (PP p) = PP [ Star (Pure f) p' | p' <- p ]++instance Applicative (ListProd l env) where+ pure f = PP [ Pure f ]+ + (PP f) <*> (PP g) = PP [ Star f' g' | f' <- f, g' <- g ]++instance Alternative (ListProd l env) where+ empty = PP []+ + (PP f) <|> (PP g) = PP (f ++ g)++ some p = fixPrd (one <|> more)+     where  one  = (:[]) <$> toFL p +            more = (:)   <$> toFL p <*> varPrd+++ many p = fixPrd (none <|> more) +     where  none = pure [] +            more = (:)   <$> toFL p <*> varPrd++toFL :: ListProd l env a -> ListProd (FL b) env a+toFL (PP p) = PP $ map prodToFL p++prodToFL :: Prod l a env -> Prod (FL b) a env+prodToFL (Star      f  g)  = Star      (prodToFL f) (prodToFL g)+prodToFL (FlipStar  f  g)  = FlipStar  (prodToFL f) (prodToFL g)+prodToFL (Sym       s)     = Sym s+prodToFL (Pure      a)     = Pure a+prodToFL (Fix       f)     = Fix f+prodToFL Var               = unsafeCoerce Var -- the other option is to add an error here+++pSome :: ListProd (FL [a]) env a -> ListProd l env [a]+pSome p = fixPrd (one <|> more)+     where  one  = (:[]) <$> p +            more = (:)   <$> p <*> varPrd++pMany :: ListProd (FL [a]) env a -> ListProd l env [a]+pMany p = fixPrd (none <|> more)+     where  none = pure [] +            more = (:)   <$> p <*> varPrd+++------------------------+-- IDIOMS++-- | The  `Ii` is to be pronounced as @stop@+data Ii = Ii ++-- | The function `iI` is to be pronounced as @start@+iI ::Idiomatic  l env (a -> a) g => g+iI = idiomatic (pure id)++class Idiomatic l env f g  | g -> f l env  where+    idiomatic :: ListProd l env f -> g++instance  Idiomatic l env x  (Ii -> ListProd l env x) where+    idiomatic ix Ii = ix+instance  Idiomatic l env f g  => Idiomatic  l env (a -> f) (ListProd l env a -> g) where+    idiomatic isf is = idiomatic (isf <*> is)++instance Idiomatic l env f g => Idiomatic l env ((a -> b) -> f)  ((a -> b) -> g) where+    idiomatic isf f = idiomatic (isf <*> (pure f))++instance (Idiomatic  l env f g) +       => Idiomatic  l env f (String -> g) where+    idiomatic isf str = idiomatic (isf <* (tr str))+++-------------------------------------------------------------------------------+++newtype  LSPair nt a t env = LSPair { symLSPair :: (Symbol a t env) }  ++labelLSPair :: LSPair nt a t env -> nt+labelLSPair _ = undefined++infixr 6 ^= +(^=) :: nt -> Symbol a t env -> LSPair nt a t env+(^=) _ = LSPair+ infixr 6 <=> -(<=>) ::  a -> b env -> EP a b env-(<=>) = EP+class LabelSymbol t v v' | t v -> v' where + (<=>) :: label -> Symbol v t env -> ListProd l env (LVPair label v')  -infixr 5 <.>+instance LabelSymbol TAttT v (Record HNil -> v) where+ l <=> v =  (\x -> l .=. (\(Record HNil) -> x)) <$> (PP [ Sym v ]) -data PreProd a b env = PreProd (a -> (Prod b env))+instance LabelSymbol TNonT v v where+ l <=> v =  (l .=.) <$> (PP [ Sym v ]) -class ProdSeq a b c d | a c -> b d  where-  (<.>) :: a env -> b env -> PreProd c d env+instance LabelSymbol TTerm v v where -- only to have all the instances+ l <=> v =  (l .=.) <$> (PP [ Sym v ]) -instance (HExtend (LVPair t v) l l') => ProdSeq  -        (EP t (Symbol b TNonT))-        (PreProd (l -> v -> t2) (b -> a))-        (l' -> t2)-        a where -  (EP chn s)   <.>  (PreProd ps) = PreProd $ -         \f ->  let f' r = \x -> f (chn .=. x .*. r) -                in   Seq s $ ps f' -instance (HExtend (LVPair t (Record HNil -> v)) l l') => ProdSeq-        (EP t (Symbol b TAttT))-        (PreProd (l -> v -> t2) (b -> a))-        (l' -> t2)-        a where+-------------------------------------------------------------------------------+-- Show instances for the Grammars+-- Just for debugging purposes -   (EP pn s) <.> (PreProd pp) =  PreProd $ \r ->  Seq s $ pp (f r)-               where f r p = \x -> r (pn .=. (\(Record HNil) -> x) .*. p) +instance Show (Grammar a) where+ show (Grammar r prods) = show r ++ "\n" ++ show prods +instance ShowEnv (Env (Productions l) env env') => Show (Env (Productions l) env env') where+ show env = showEnv 0 env -instance ProdSeq-        (Symbol DTerm TTerm)-        (PreProd (t1 -> DTerm -> t2) (DTerm -> a))-        (t1 -> t2)-        a where+class ShowEnv a where+    showEnv :: Int -> a -> String -  s  <.> (PreProd pp) = PreProd $ \r -> Seq s $ pp (f r)-               where f r p = \DTerm -> r p +instance ShowEnv (Env (Productions l) env env') where+    showEnv _ (Empty)         = "\n"+    showEnv n (Ext nts nont)  = show n ++ "->" ++ show nont ++ "\n" ++ showEnv (n+1) nts+ +instance Show (Productions l a env) where+ show (PS prods) = show prods -prdEnd ::  PreProd (Record HNil -> b) b env-prdEnd = PreProd $ \f -> End (f emptyRecord)+instance Show (Prod l a env) where+ show (Star pf pa)      = "(" ++ show pf ++ "<*>" ++ show pa ++ ")"+ show (FlipStar pa pf)  = "(" ++ show pa ++ "<**>" ++ show pf  ++ ")"+ show (Sym s)           = show s + show (Pure _)          = "pure"+ show (Fix f)           = "fix " ++ show f+ show Var               = "var" -prd ::  (a -> b) -> PreProd (a -> b) t t1 -> Prod t t1-prd sem (PreProd ps) = ps sem  +instance Show (Symbol a t env) where+ show (Term s)    = show s+ show (Nont r)    = show r+ show (TermInt)   = "int"+ show (TermChar)  = "char"+ show (TermVarid) = "var"+ show (TermConid) = "con"+ show (TermOp)    = "op" -prdId ::  Symbol a TNonT env -> Prod a env-prdId nt = Seq nt  $ End id+instance Show (Ref a env) where+ show Zero     = "0"+ show (Suc r)  = show  $ (1::Int) + ((read . show) r) 

@@ -1,69 +1,72 @@ {-# LANGUAGE Arrows, ExistentialQuantification, GADTs, Rank2Types, FlexibleContexts, ScopedTypeVariables     , EmptyDataDecls, MultiParamTypeClasses, FlexibleInstances, OverlappingInstances, FunctionalDependencies, UndecidableInstances-    , TypeFamilies  #-}+  #-}  module Language.Grammars.SyntaxMacros where  import Language.AbstractSyntax.TTTAS import Control.Arrow -import UU.Parsing.Interface hiding (Symbol,parse,Ok) import qualified UU.Parsing as UU import Language.Grammars.SyntaxMacros.Scanner -import Language.Grammars.Grammar+import Language.Grammars.Grammar +import Language.Grammars.Transformations.RemoveFix+import Language.Grammars.Transformations.RemoveEmpties import Language.Grammars.Transformations.LeftCorner-import Language.Grammars.Transformations.LeftFact -type GramTrafo = Trafo Unit Productions-type ExtGram      env      nts   -           = GramTrafo env  ()   (nts env)-type SyntaxMacro  env nts  nts'  -           = GramTrafo env  (nts env)  (nts' env) +type GramTrafo = Trafo Unit (Productions TL)+type ExtGram      env  start  nts   +           = GramTrafo env  ()   (Export start nts env)+type SyntaxMacro  env  start  nts  start' nts'  +           = GramTrafo env  (Export start nts env)  (Export start' nts' env)+ data Export start nts env = Export (Symbol start TNonT env) (nts env)  -- add a new non-terminal to the grammar-addNT  ::  GramTrafo env [Prod a env] (Symbol a TNonT env)+addNT  ::  GramTrafo env (ListProd TL env a) (Symbol a TNonT env) addNT  =  proc  p -> do -                r  <- newSRef -< PS p+                r  <- newSRef -< prod p                 returnA -< Nont r   -- add productions to an existing non-terminal addProds  ::  GramTrafo  env -                         (Symbol a TNonT env, [Prod a env]) ()-addProds  = proc (nt, prds) -> do+                         (Symbol a TNonT env, ListProd TL env a) ()+addProds  = proc (nont, prds) -> do       updateFinalEnv  -< -         updateEnv (\(PS ps) -> PS $ prds ++ ps) (getRefNT nt)+         updateEnv (\ps -> PS $ (unPP prds) ++ (unPS ps)) (getRefNT nont)    -- close the grammar-closeGram :: (forall env. ExtGram  env (Export a nts)) +closeGram :: (forall env. ExtGram  env a nts)                  -> Grammar a  closeGram prds  = case runTrafo prds Unit () of      Result _ (Export (Nont r) _) gram -            -> (leftfactoring . leftcorner) $ Grammar r gram-+            -> (leftCorner . removeEmpties . removeFix) $ Grammar r gram  extendGram  ::  (NTRecord (nts env), NTRecord (nts' env))  -            =>  ExtGram env (Export start nts) -                -> SyntaxMacro env (Export start nts) (Export start' nts') -                -> ExtGram env (Export start' nts')+            =>  ExtGram env start nts +                -> SyntaxMacro env start nts start' nts' +                -> ExtGram env start' nts' extendGram g sm = g >>> sm +(<++>)      ::  (NTRecord (nts env), NTRecord (nts' env))  +            =>  ExtGram env start nts +                -> SyntaxMacro env start nts start' nts' +                -> ExtGram env start' nts'++(<++>) = extendGram+ exportNTs ::  NTRecord (nts env) => GramTrafo env (Export start nts env) (Export start nts env) exportNTs = returnA   -- extensible record -newtype  NTField nt a env = NTField { symbolNTField :: (Symbol a TNonT env) }   -labelNTField :: NTField nt a env -> nt-labelNTField _ = undefined--data  NTCons nt v l env  = NTCons (NTField nt v env) (l env)+data  NTCons nt v l env  = NTCons (LSPair nt v TNonT env) (l env) data  NTNil         env  = NTNil  class NTRecord r @@ -83,13 +86,10 @@ ntNil :: NTNil env ntNil = NTNil -infixr 4 ^= -(^=) :: nt -> (Symbol a TNonT env) -> NTField nt a env-(^=) _ = NTField  -infixr 2 ^| -(^|) :: NTRecord (NTCons nt a l env) => NTField nt a env -> l env -> NTCons nt a l env+infixr 4 ^| +(^|) :: NTRecord (NTCons nt a l env) => LSPair nt a TNonT env -> l env -> NTCons nt a l env (^|) = NTCons  @@ -101,58 +101,70 @@ instance Fail (NotFound nt) => GetNT nt (NTNil env) r where  getNT = undefined instance GetNT nt  (NTCons nt v l env) (Symbol v TNonT env) where -- using overlapping- getNT _ (NTCons f _)  = symbolNTField f+ getNT _     (NTCons f _)    = symLSPair f instance GetNT nt1 (l env) r => GetNT nt1 (NTCons nt2 v l env) r where- getNT nt (NTCons _ l)  = getNT nt l+ getNT nont  (NTCons _ l)    = getNT nont l +instance GetNT nt (nts env) r => GetNT nt (Export start nts env) r where+ getNT nont  (Export _ nts)  = getNT nont nts +getStart :: Export start nts env ->  (Symbol start TNonT env)+getStart (Export start _) = start++exportList :: Symbol start TNonT env -> (NTNil env -> nts env) -> Export start nts env+exportList r l = Export r $ l ntNil++export  ::  (NTRecord (l env), NotDuplicated nt (l env))+        =>  nt -> Symbol a TNonT env +        -> l env ->  NTCons nt a l env+export l nont = (^|) (l ^= nont) + -- COMPILE -------------------------------------------------------------------- -pInt            ::   Parser Token Int-pChr            ::   Parser Token Char-pCon            ::   Parser Token String-pVar            ::   Parser Token String-pOp             ::   Parser Token String+pInt            ::   UU.Parser Token Int+pChr            ::   UU.Parser Token Char+pCon            ::   UU.Parser Token String+pVar            ::   UU.Parser Token String+pOp             ::   UU.Parser Token String -pChr            =    head <$> pChar-pInt            =    read <$> pInteger-pCon            =    id <$> pConid-pVar            =    id <$> pVarid-pOp             =    id <$> pVarsym+pChr            =    head UU.<$> pChar+pInt            =    read UU.<$> pInteger+pCon            =    id UU.<$> pConid+pVar            =    id UU.<$> pVarid+pOp             =    id UU.<$> pVarsym -pTerm           ::  (UU.Parsing.Interface.IsParser p Token) +pTerm           ::  (UU.IsParser p Token)                  =>  String -> p DTerm-pTerm t         =  const DTerm <$>   (pKey t)+pTerm t         =   pKey t  newtype Const f a s = C {unC :: f a}  -compile :: Grammar a -> Parser Token a+compile :: Grammar a -> UU.Parser Token a compile (Grammar (start :: Ref a env) rules)                         = unC (lookupEnv start result)   where  result  =             mapEnv -          (\ (PS ps) -> C (foldr1 (<|>) [ comp p | p <- ps]))+          (\ (PS ps) -> C (foldr1 (UU.<|>) [ comp p | p <- ps]))           rules-         comp :: forall t . Prod t env -> Parser Token t-         comp (End x)   = pLow x -         comp (Seq (Term t) ss) -                       = flip ($)  <$> pTerm t <*> comp ss -         comp (Seq (Nont n) ss) -                       = flip ($)  <$> unC (lookupEnv n result)-                                     <*> comp ss-         comp (Seq (NontInt) ss) -                       = flip ($)  <$> pInt <*> comp ss -         comp (Seq (NontChar) ss) -                       = flip ($)  <$> pChr <*> comp ss -         comp (Seq (NontVarid) ss) -                       = flip ($)  <$> pVar <*> comp ss -         comp (Seq (NontConid) ss) -                       = flip ($)  <$> pCon <*> comp ss -         comp (Seq (NontOp) ss) -                       = flip ($)  <$> pOp  <*> comp ss  +         comp :: forall t . Prod TL t env -> UU.Parser Token t +         comp (Star     x y)   = comp x UU.<*>   comp y+         comp (FlipStar x y)   = comp x UU.<**>  comp y+         comp (Pure     x)     = UU.pLow x++         comp (Sym (Term t))   = pTerm t+         comp (Sym (Nont n))   = unC (lookupEnv n result)++         comp (Sym TermInt)    = pInt+         comp (Sym TermChar)   = pChr+         comp (Sym TermVarid)  = pVar+         comp (Sym TermConid)  = pCon+         comp (Sym TermOp)     = pOp++         comp (Fix _)          = error "This shouldn't be happening!"+ mapEnv  ::  (forall a . f a s -> g a s)           ->  Env f s env -> Env g s env mapEnv  _ Empty       = Empty@@ -161,28 +173,28 @@  -- PARSE ---------------------------------------------------------------------- -type ParseMsg = Message Token (Maybe Token)+type ParseMsg = UU.Message Token (Maybe Token)  data ParseResult a = Ok  a                    | Rep a [ParseMsg]        deriving Show -parse :: Parser Token a -> [Token] -> ParseResult a+parse :: UU.Parser Token a -> [Token] -> ParseResult a parse p input = case rparse p input of                   (a,[]  ) -> Ok a                   (a,msgs) -> Rep a msgs  -rparse :: Parser Token a -> [Token] -> (a, [ParseMsg])-rparse p input = let ((Pair a _),msgs) =  eval (UU.parse p input)+rparse :: UU.Parser Token a -> [Token] -> (a, [ParseMsg])+rparse p input = let (UU.Pair a _,msgs) =  eval (UU.parse p input)                  in (a,msgs)- where eval :: Steps a Token (Maybe Token) -> (a, [ParseMsg])-       eval (OkVal v        r) = let (a,msgs) = v `seq` eval r -                                 in  (v a,msgs)-       eval (UU.Ok          r) = eval r-       eval (Cost  _        r) = eval  r-       eval (StRepair _ msg r) = let (v,msgs) = eval r -                                 in  (v,msg:msgs)-       eval (Best _   r     _) = eval  r-       eval (NoMoreSteps v   ) = (v,[]) + where eval :: UU.Steps a Token (Maybe Token) -> (a, [ParseMsg])+       eval (UU.OkVal v        r) = let (a,msgs) = v `seq` eval r +                                    in  (v a,msgs)+       eval (UU.Ok             r) = eval r+       eval (UU.Cost  _        r) = eval  r+       eval (UU.StRepair _ msg r) = let (v,msgs) = eval r +                                    in  (v,msg:msgs)+       eval (UU.Best _   r     _) = eval  r+       eval (UU.NoMoreSteps v   ) = (v,[])  

@@ -1,64 +1,75 @@-{-# OPTIONS -fglasgow-exts #-}-+{-# LANGUAGE RankNTypes, GADTs #-} module Language.Grammars.Transformations.GramTrafo where  import Language.AbstractSyntax.TTTAS import Language.Grammars.Grammar -newtype MapA_X env a env'-  = MapA_X (forall x t. Symbol x t env -> Maybe (Ref (x -> a) env'))+data MapA_X env a env'+  = MapA_X (forall x t. Symbol (x->a)  t env -> Maybe (Ref x       env')) -- Star+           (forall x t. Symbol x       t env -> Maybe (Ref (x->a)  env')) -- Flip + emptyMap :: MapA_X env a env'-emptyMap  = MapA_X (const Nothing)+emptyMap  = MapA_X (const Nothing) (const Nothing) -extendMap :: Symbol x t env -> MapA_X env a env'-          -> MapA_X env a (env',x->a)-extendMap  x (MapA_X m) -       = MapA_X  (\s -> case matchSym s x of+extendMapS :: Symbol (x->a) t env -> MapA_X env a env'+           -> MapA_X env a (env',x)+extendMapS  x (MapA_X ms mf) +        = MapA_X  (\s -> case matchSym s x of                                      Just Eq -> Just Zero-                                     Nothing -> fmap Suc (m s)-                      )+                                     Nothing -> fmap Suc (ms s))+                  (\s -> fmap Suc (mf s)) +extendMapF :: Symbol x t env -> MapA_X env a env'+           -> MapA_X env a (env',x->a)+extendMapF  x (MapA_X ms mf) +        = MapA_X  (\s -> fmap Suc (ms s))+                  (\s -> case matchSym s x of+                                     Just Eq -> Just Zero+                                     Nothing -> fmap Suc (mf s))+                  -type GramTrafo env a = Trafo (MapA_X env a) Productions +type GramTrafo env a = Trafo (MapA_X env a) (Productions TL) + initMap :: GramTrafo env a s c d-        -> Trafo Unit Productions s c d+        -> Trafo Unit (Productions TL) s c d initMap (Trafo st)          = Trafo (\_ -> case st emptyMap of                             TrafoE _ f -> TrafoE Unit f                 ) -newNontR ::  forall x t env s a -         .   Symbol x t env -         ->  GramTrafo env a s (Productions (x->a) s) (Ref (x->a) s)-newNontR x = Trafo $ \m -> extEnv (extendMap x m)+newNontRS  ::  forall x t env s a +           .   Symbol (x->a) t env +           ->  GramTrafo env a s (Productions TL x s) (Ref x s)+newNontRS x = Trafo $ \m -> extEnv (extendMapS x m) +newNontRF  ::  forall x t env s a +           .   Symbol x t env +           ->  GramTrafo env a s (Productions TL (x->a) s) (Ref (x->a) s)+newNontRF x = Trafo $ \m -> extEnv (extendMapF x m) + newtype Mapping old new             = Mapping (Env Ref new old)   map2trans :: Mapping env s -> T env s map2trans (Mapping env) -     = T (\r -> (lookupEnv r env))+     = T (flip lookupEnv env) -mapProd  :: T env1 env2 -> Prod a env1 -> Prod a env2-mapProd _ (End x)            = End x-mapProd t (Seq (Term x) r)   = Seq  (Term x) -                                    (mapProd t r) -mapProd t (Seq (Nont x) r)   = Seq (Nont (unT t x)) -                                   (mapProd t r)-mapProd t (Seq NontInt r)    = Seq NontInt -                                   (mapProd t r)-mapProd t (Seq NontChar r)   = Seq NontChar -                                   (mapProd t r)-mapProd t (Seq NontVarid r)  = Seq NontVarid -                                   (mapProd t r)-mapProd t (Seq NontConid r)  = Seq NontConid -                                   (mapProd t r)-mapProd t (Seq NontOp r)     = Seq NontOp -                                   (mapProd t r)-+mapProd  :: T env1 env2 -> Prod l a env1 -> Prod l a env2+mapProd t (Sym (Nont x))      = Sym (Nont (unT t x)) +mapProd _ (Sym (Term x))      = Sym  (Term x) +mapProd _ (Sym TermInt)       = Sym TermInt +mapProd _ (Sym TermChar)      = Sym TermChar +mapProd _ (Sym TermVarid)     = Sym TermVarid +mapProd _ (Sym TermConid)     = Sym TermConid +mapProd _ (Sym TermOp)        = Sym TermOp +mapProd _ (Pure x)            = Pure x+mapProd t (Star r l)          = Star     (mapProd t r) (mapProd t l)+mapProd t (FlipStar r l)      = FlipStar (mapProd t r) (mapProd t l)+mapProd t (Fix (PS ps))       = Fix $ PS (map (mapProd t) ps)+mapProd _ Var                 = Var 

@@ -1,6 +1,6 @@ {-# OPTIONS -XExistentialQuantification -XArrows -XDoRec -XGADTs #-} -module Language.Grammars.Transformations.LeftCorner (leftcorner) where+module Language.Grammars.Transformations.LeftCorner (leftCorner) where  import Language.AbstractSyntax.TTTAS import Language.Grammars.Grammar@@ -8,24 +8,24 @@ import Control.Arrow  -leftcorner :: forall a . Grammar a -> Grammar a-leftcorner (Grammar start productions)+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 :: GramEnv env env +        -> Trafo Unit (Productions TL) 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  ::  GramEnv env env+        ->  GramEnv env env' +        ->  Trafo  Unit (Productions TL) s (T env s) +                                           (Mapping env' s) rules1 _ Empty                = proc _ ->         returnA -< Mapping Empty  @@ -36,94 +36,188 @@             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 :: forall env a s. GramEnv env env+          -> [Prod TL a env]+          -> Trafo Unit (Productions TL) s (T env s) (Productions TL a s) app_rule1 productions prods =  initMap            ( proc tenv_s -> -                do pss <- sequenceA  (map  (rule1 productions) prods) -< tenv_s +                do pss <- sequenceA  (map  (rule1 productions . accessLeftMost) 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) +rule1  :: GramEnv env env -> Prod TL a env +       -> GramTrafo env a s (T env s) (Productions TL a s)++rule1 gram (Star (Sym x) beta)       = proc tenv_s ->-        do  insert gram x -< (tenv_s, mapProd tenv_s beta)-                      +        do  insertS gram x -< (tenv_s, mapProd tenv_s beta) -rule2  :: Env Productions env env -       -> Symbol x t env -       -> GramTrafo env a s (T env s, Ref (x -> a) s) -                            (Productions a s)-rule2 _    (Term a) +rule1 gram (FlipStar (Sym x) beta) +     = proc tenv_s ->+        do  insertF gram x -< (tenv_s, mapProd tenv_s beta)++rule1 gram (Sym x) +     = rule1 gram $ FlipStar (Sym x) (Pure id)++rule1 _ (Pure _) +     = error "Left-Corner(1): The grammar has empty productions."+rule1 _ _+     = error "Left-Corner(2): error in the transformation!!!"+++accessLeftMost :: Prod TL a env -> Prod TL a env+accessLeftMost (Star      (Star      f g) h) +  = accessLeftMost $ FlipStar f (Star (Star (Pure (\g' h' f' -> f' g' h'))   g) h)+accessLeftMost (Star      (FlipStar  f g) h) +  = accessLeftMost $ FlipStar f (Star (Star (Pure flip)                      g) h)+accessLeftMost (FlipStar  (Star      f g) h) +  = accessLeftMost $ FlipStar f (Star (Star (Pure (\g' h' f' -> h' (f' g'))) g) h)+accessLeftMost (FlipStar  (FlipStar  f g) h) +  = accessLeftMost $ FlipStar f (Star (Star (Pure (\g' h' f' -> h' (g' f'))) g) h)+accessLeftMost p = p ++rule2S  :: GramEnv env env +        -> Symbol (x->a) t env +        -> GramTrafo env a s (T env s, Ref x s) +                             (Productions TL a s)+rule2S gram (Nont b) +     = case lookupEnv b gram of+          PS ps ->  proc (tenv_s, a_x) ->+                      do pss <- sequenceA  +                                (map  (rule2bS gram  . accessLeftMost) ps) -< (tenv_s, a_x)+                         returnA -< PS (concatMap unPS pss)++++rule2bS  :: GramEnv env env +         -> Prod TL (b->a) env +         -> GramTrafo env a s (T env s, Ref b s) +                              (Productions TL a s)++rule2bS gram (Star (Sym x) beta) +     = proc (tenv_s, a_b) ->+         do insertF gram x -< (tenv_s, Star (Star (Pure (\b y bya -> bya b y)) (mapProd tenv_s beta)) (Sym $ Nont a_b) )++rule2bS gram (FlipStar (Sym x) beta) +     = proc (tenv_s, a_b) ->+         do insertF gram x -< (tenv_s, Star (Star (Pure (\bya y b -> bya b y)) (mapProd tenv_s beta)) (Sym $ Nont a_b) )++rule2bS gram (Sym x) +     = rule2bS gram $ FlipStar (Sym x) (Pure id)++rule2bS _ (Pure _)+     = error "Left-Corner(3): The grammar has empty productions."++rule2bS _ _+     = error "Left-Corner(4): error in the transformation!!!"++--++rule2F  :: GramEnv env env +        -> Symbol x t env +        -> GramTrafo env a s (T env s, Ref (x->a) s) +                             (Productions TL a s)+rule2F _    (Term a)       = proc (_, a_x) ->-        do  returnA -< PS [rule2a a a_x]-rule2 gram (Nont b) +        do  returnA -< PS [rule2aF a a_x]+rule2F 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)+                                (map  (rule2bF gram  . accessLeftMost) ps) -< (tenv_s, a_x)                          returnA -< PS (concatMap unPS pss)-rule2 _    NontInt +rule2F _    TermInt       = proc (_, a_x) ->-        do  returnA -< PS [rule2a' NontInt a_x]-rule2 _    NontChar +        do  returnA -< PS [rule2a'F TermInt a_x]+rule2F _    TermChar       = proc (_, a_x) ->-        do  returnA -< PS [rule2a' NontChar a_x]-rule2 _    NontVarid +        do  returnA -< PS [rule2a'F TermChar a_x]+rule2F _    TermVarid       = proc (_, a_x) ->-        do  returnA -< PS [rule2a' NontVarid a_x]-rule2 _    NontConid +        do  returnA -< PS [rule2a'F TermVarid a_x]+rule2F _    TermConid       = proc (_, a_x) ->-        do  returnA -< PS [rule2a' NontConid a_x]-rule2 _    NontOp +        do  returnA -< PS [rule2a'F TermConid a_x]+rule2F _    TermOp       = proc (_, a_x) ->-        do  returnA -< PS [rule2a' NontOp a_x]+        do  returnA -< PS [rule2a'F TermOp a_x]  -rule2a' :: Symbol a t s -> Ref (a -> b) s -> Prod b s-rule2a' s refA_a-     =  Seq s $ Seq (Nont refA_a) $ End ($) +rule2a'F :: Symbol a t s -> Ref (a->b) s -> Prod TL b s+rule2a'F s refA_a+     =  FlipStar (Sym s) (Sym $ Nont refA_a) -- (flip ($)) <$> (Sym s) <*> nont refA_a  -rule2a :: String -> Ref (DTerm -> a) s -> Prod a s-rule2a a refA_a-     =  Seq (Term a) $ Seq (Nont refA_a) $ End ($) +rule2aF :: String -> Ref (DTerm -> a) s -> Prod TL a s+rule2aF a refA_a+     =  FlipStar (Sym $ Term a) (Sym $ Nont refA_a) -- (flip ($)) <$> term a <*> nont refA_a -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) ++rule2bF  :: GramEnv env env +         -> Prod TL b env +         -> GramTrafo env a s (T env s, Ref (b -> a) s) +                              (Productions TL a s)++rule2bF gram (Star (Sym x) beta)       = proc (tenv_s, a_b) ->-         do insert gram x -< (tenv_s, append  (flip (.)) -                                              (mapProd tenv_s beta) -                                              (Nont a_b))+         do insertF gram x -< (tenv_s, Star (Star (Pure (\b xa bx -> xa (bx b))) (mapProd tenv_s beta)) (Sym $ Nont a_b) ) -insert ::  forall x t env s a-       .   Env Productions env env -       ->  Symbol x t env-       ->  GramTrafo env a s  (T env s, Prod (x->a) s)-                              (Productions a s)-insert gram x = +rule2bF gram (FlipStar (Sym x) beta) +     = proc (tenv_s, a_b) ->+         do insertF gram x -< (tenv_s, Star (Star (Pure (flip (.))) (mapProd tenv_s beta)) (Sym $ Nont a_b) )++rule2bF gram (Sym x) +     = rule2bF gram $ FlipStar (Sym x) (Pure id)++rule2bF _ (Pure _)+     = error "Left-Corner(5): The grammar has empty productions."++rule2bF _ _+     = error "Left-Corner(6): error in the transformation!!!"++insertS ::  forall x t env s a+        .   GramEnv env env +        ->  Symbol (x->a) t env+        ->  GramTrafo env a s  (T env s, Prod TL x s)+                               (Productions TL a s)+insertS gram x =       Trafo (-           \(MapA_X m) -> case m x of-                       Just r   -> extendA_X (MapA_X m) r+           \(MapA_X ms mf) -> case ms x of+                       Just r   -> extendA_X (MapA_X ms mf) r+                                   Nothing  -> let  Trafo step = insertNewA_X -                                   in   step (MapA_X m)+                                   in   step (MapA_X ms mf)            )      where        insertNewA_X = proc (tenv_s,p) ->-                     do  r <- newNontR x -< PS [p]-                         rule2 gram x    -< (tenv_s,r)+                     do  r <- newNontRS x  -< PS [p]+                         rule2S 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))+insertF ::  forall x t env s a+        .   GramEnv env env +        ->  Symbol x t env+        ->  GramTrafo env a s  (T env s, Prod TL (x->a) s)+                               (Productions TL a s)+insertF gram x = +     Trafo (+           \(MapA_X ms mf) -> case mf x of+                       Just r   -> extendA_X (MapA_X ms mf) r+           +                       Nothing  -> let  Trafo step = insertNewA_X +                                   in   step (MapA_X ms mf)+           )+     where+       insertNewA_X = proc (tenv_s,p) ->+                     do  r <- newNontRF x  -< PS [p]+                         rule2F gram x     -< (tenv_s,r)  +extendA_X  :: m env2 -> Ref x env2 +            -> TrafoE m (Productions TL) s env2 (t, Prod TL x s) (Productions TL a env)+extendA_X m r = fmap  (const $ PS []) $ +                       updateSRef m r (\(_,p) (PS ps) -> PS (p:ps))  

@@ -1,158 +0,0 @@-{-# OPTIONS -XExistentialQuantification -XArrows -XDoRec #-}--module Language.Grammars.Transformations.LeftFact (leftfactoring) where--import Language.AbstractSyntax.TTTAS-import Language.Grammars.Grammar-import Language.Grammars.Transformations.GramTrafo-import Control.Arrow-import Data.Maybe------list of repeated symbols (with hidden type)-data AnySym env = forall x t. AnySym (Symbol x t 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 _ ->-            do   rec  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 t env s a x. Symbol x t 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 f ->-                                              ( PS []-                                              , t-                                              , updateEnv (\(PS ps) -                                                             -> PS (p:ps))-                                                          r e-                                              , f-                                              )-                                         )-           )---addprod :: Symbol x t env -> GramTrafo env a s (T env s, Ref (x -> a) s) -                                           (Productions a s)     -addprod (Term x) = proc (_,    a__x) -> -                      do returnA -< PS [ Seq (Term x) $ Seq (Nont a__x) $ End ($)]-addprod (Nont r) = proc (env2s, a__x) -> -                      do returnA -< PS [ Seq (Nont (unT env2s r)) $ Seq (Nont a__x) -                                         $ End ($)]-addprod (NontInt) = proc (_, a__x) -> -                      do returnA -< PS [ Seq NontInt $ Seq (Nont a__x) $ End ($)]-addprod (NontChar) = proc (_, a__x) -> -                      do returnA -< PS [ Seq NontChar $ Seq (Nont a__x) $ End ($)]-addprod (NontVarid) = proc (_, a__x) -> -                      do returnA -< PS [ Seq NontVarid $ Seq (Nont a__x) $ End ($)]-addprod (NontConid) = proc (_, a__x) -> -                      do returnA -< PS [ Seq NontConid $ Seq (Nont a__x) $ End ($)]-addprod (NontOp) = proc (_, a__x) -> -                      do returnA -< PS [ Seq NontOp $ Seq (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 a t env -> [AnySym env] -> Bool-iselem _ []              = False-iselem x ((AnySym y):ys) = case (matchSym x y) of-                                  (Just Eq) -> True-                                  Nothing   -> iselem x ys -

@@ -0,0 +1,154 @@++module Language.Grammars.Transformations.RemoveEmpties (removeEmpties) where+++import Language.Grammars.Grammar+import Language.AbstractSyntax.TTTAS+++data HasEmpty a env = Unknown | HasEmpty (Prod TL a env) | HasNotEmpty+ deriving (Show)+++removeEmpties :: Grammar a -> Grammar a+removeEmpties (Grammar start prods) +     =  Grammar start $ removeEmptiesEnv (findEmpties prods) prods ++++findEmpties :: GramEnv env env -> Env HasEmpty env env +findEmpties prods = findEmpties' prods (initEmpties prods)+         where+            findEmpties' prds empties = +                  case stepFindEmpties empties prds empties of+                      (empties', True,  _)     -> findEmpties' prds empties'+                      (empties', False, False) -> empties'+                      (_,        False, True)  -> error "Remove Empties(1): Incorrect Grammar!!"++initEmpties :: GramEnv use def -> Env HasEmpty use def +initEmpties Empty        = Empty+initEmpties (Ext nts _)  = Ext (initEmpties nts) Unknown++stepFindEmpties :: Env HasEmpty use use -> GramEnv use def -> Env HasEmpty use def +                -> (Env HasEmpty use def, Bool, Bool) +stepFindEmpties _       Empty          Empty        +    = (Empty, False, False)+stepFindEmpties empties (Ext rprd prd) (Ext re e)   +    = let (re',rchanged,rhasUnk) = stepFindEmpties empties rprd re+          (e', changed, hasUnk)  = updateEmpty empties prd e+      in  (Ext re' e', changed || rchanged, hasUnk || rhasUnk)+stepFindEmpties _       _              _ +    = error "RemoveEmpties(2): Error in the transformation!!!"        +++updateEmpty :: Env HasEmpty use use -> (Productions TL) a use -> HasEmpty a use  +            -> (HasEmpty a use, Bool, Bool) +updateEmpty _       _   (HasEmpty p) = (HasEmpty p,  False, False)+updateEmpty _       _   HasNotEmpty  = (HasNotEmpty, False, False)+updateEmpty empties prd Unknown      = case hasEmpty empties prd of+                                        Unknown -> (Unknown, False, True)+                                        e       -> (e,       True,  False)++hasEmpty :: Env HasEmpty env env -> (Productions TL) a env -> HasEmpty a env+hasEmpty empties (PS ps)= foldr (\p re -> combHasEmpty (isEmpty p empties) re) HasNotEmpty ps+++combHasEmpty :: HasEmpty a env -> HasEmpty a env -> HasEmpty a env+combHasEmpty (HasEmpty _)     (HasEmpty _)     = error "Remove Empties(3): Ambiguous Grammar!!!"+combHasEmpty _                (HasEmpty p)     = HasEmpty p+combHasEmpty (HasEmpty p)     _                = HasEmpty p+combHasEmpty HasNotEmpty      HasNotEmpty      = HasNotEmpty+combHasEmpty _                Unknown          = Unknown+combHasEmpty Unknown          _                = Unknown+++isEmpty :: Prod TL a env -> Env HasEmpty env env -> HasEmpty a env+isEmpty (Pure a)              _       = HasEmpty (Pure a)+isEmpty (Sym (Term _))        _       = HasNotEmpty+isEmpty (Sym (TermInt))       _       = HasNotEmpty+isEmpty (Sym (TermChar))      _       = HasNotEmpty+isEmpty (Sym (TermVarid))     _       = HasNotEmpty+isEmpty (Sym (TermConid))     _       = HasNotEmpty+isEmpty (Sym (TermOp))        _       = HasNotEmpty+isEmpty (Sym (Nont r))        empties = lookupEnv r empties+isEmpty (Star pl pr)          empties = case isEmpty pl empties of+                                         HasEmpty (Pure f)  -> case isEmpty pr empties of+                                                                HasEmpty (Pure x)  -> HasEmpty $ Pure (f x)+                                                                HasEmpty _         -> error "RemoveEmpties(4): Error in the transformation!!!"+                                                                HasNotEmpty        -> HasNotEmpty+                                                                Unknown            -> Unknown+                                         HasEmpty _         -> error "RemoveEmpties(5): Error in the transformation!!!"+                                         HasNotEmpty        -> HasNotEmpty+                                         Unknown            -> case isEmpty pr empties of+                                                                HasNotEmpty        -> HasNotEmpty+                                                                _                  -> Unknown+isEmpty (FlipStar pl pr)      empties = case isEmpty pl empties of+                                         HasEmpty (Pure x)  -> case isEmpty pr empties of+                                                                HasEmpty (Pure f)  -> HasEmpty $ Pure (f x)+                                                                HasEmpty _         -> error "RemoveEmpties(6): Error in the transformation!!!"+                                                                HasNotEmpty        -> HasNotEmpty+                                                                Unknown            -> Unknown+                                         HasEmpty _         -> error "RemoveEmpties(7): Error in the transformation!!!"+                                         HasNotEmpty        -> HasNotEmpty+                                         Unknown            -> case isEmpty pr empties of+                                                                HasNotEmpty        -> HasNotEmpty+                                                                _                  -> Unknown++isEmpty (Fix _)               _       = error "RemoveEmpties(8): cannot transform grammars with Fix constructions."++++removeEmptiesEnv :: Env HasEmpty use use -> GramEnv use def -> GramEnv use def+removeEmptiesEnv _       Empty         +    = Empty+removeEmptiesEnv empties (Ext rprds prds)    +    = Ext (removeEmptiesEnv empties rprds) (removeEmpty empties prds)+++removeEmpty :: Env HasEmpty env env -> Productions TL a env -> Productions TL a env+removeEmpty empties (PS prds) = PS $ foldr ((++) . remEmptyProd) [] prds +  where +     -- if we don't allow the starting point to be empty, +     -- then we can ignore the empty part+     remEmptyProd prd = let (prd',_) = splitEmpty empties prd+                        in  prd'+++splitEmpty :: Env HasEmpty env env -> Prod TL a env -> ([Prod TL a env], Maybe (Prod TL a env))++splitEmpty  empties  (Star f g)  +    =  let (fne, fe) = splitEmpty empties f +           (gne, ge) = splitEmpty empties g ++           fne_gne   = [ Star fv gv | fv <- fne, gv <- gne ] +           fne_ge    = case ge of+                         Nothing -> []+                         Just gv -> [ Star fv gv | fv <- fne] ++           fe_gne  = case fe of+                         Nothing -> []+                         Just fv -> [ FlipStar gv fv | gv <- gne] +           fe_ge   = do +                         (Pure fv) <- fe+                         (Pure gv) <- ge+                         return $ Pure (fv gv)++       in  (fne_gne ++ fne_ge ++ fe_gne , fe_ge)+++splitEmpty  empties  (Sym (Nont r))  +    = case lookupEnv r empties of+              HasEmpty (Pure f)  -> ([Sym $ Nont r], Just (Pure f))+              HasEmpty _         -> error "RemoveEmpties(9): Error in the transformation!!!"+              HasNotEmpty        -> ([Sym $ Nont r], Nothing)+              Unknown            -> error "RemoveEmpties(10): Error in the transformation!!!"++splitEmpty  _        (Sym  s)  = ([Sym s], Nothing)+splitEmpty  _        (Pure a)  = ([],Just $ Pure a)++splitEmpty  _        (FlipStar _ _)  +    = error "RemoveEmpties(11): FlipStar cannot be used to define grammars."+splitEmpty  _        (Fix _)  +    = error "RemoveEmpties(12): cannot transform grammars with Fix constructions."++

@@ -0,0 +1,78 @@+{-# 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!!!"++