SyntaxMacros 1.0 → 1.0.3

raw patch · 19 files changed

+558/−279 lines, 19 filesdep +ListLikedep +uu-parsinglibdep −haskell98PVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: ListLike, uu-parsinglib

Dependencies removed: haskell98

API changes (from Hackage documentation)

Files

• SyntaxMacros.cabal +6/−4
• examples/LangDef.hs +20/−1
• examples/LangExt.hs +95/−36
• examples/LangSem.hs +18/−12
• examples/Main.hs +25/−14
• examples/prog.src +1/−1
• examples/prog2.src +1/−1
• examples/prog3.src +1/−1
• src/Language/Grammars/.Grammar.hs.swp binary
• src/Language/Grammars/Grammar.hs +116/−55
• src/Language/Grammars/SyntaxMacros.hs +34/−90
• src/Language/Grammars/SyntaxMacros/Machine.hs +1/−1
• src/Language/Grammars/SyntaxMacros/ScanUtils.hs +1/−1
• src/Language/Grammars/SyntaxMacros/UULib.hs +90/−0
• src/Language/Grammars/SyntaxMacros/UUParsing.hs +84/−0
• src/Language/Grammars/Transformations/GramTrafo.hs +5/−7
• src/Language/Grammars/Transformations/LeftCorner.hs +20/−21
• src/Language/Grammars/Transformations/RemoveEmpties.hs +10/−12
• src/Language/Grammars/Transformations/RemoveFix.hs +30/−22

@@ -1,5 +1,5 @@ name:               SyntaxMacros -version:            1.0+version:            1.0.3 cabal-version:      >= 1.2.3   license:            LGPL license-file:       COPYRIGHT@@ -13,11 +13,13 @@ copyright:          Universiteit Utrecht extra-source-files: README, LICENSE-LGPL  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+        build-depends:      base>=4 && <5, template-haskell>=2.4.0.1, TTTAS>=0.4.0, AspectAG>=0.2,+                            uulib>=0.9.12, uu-parsinglib >= 2.7.1, ListLike >= 3.1.0, containers>=0.3, HList>=0.2         exposed-modules:    Language.Grammars.Grammar,                              Language.Grammars.SyntaxMacros, -                            Language.Grammars.SyntaxMacros.Scanner+                            Language.Grammars.SyntaxMacros.Scanner,+                            Language.Grammars.SyntaxMacros.UUParsing,+                            Language.Grammars.SyntaxMacros.UULib         other-modules:      Language.Grammars.SyntaxMacros.Machine,                              Language.Grammars.SyntaxMacros.Token,                              Language.Grammars.SyntaxMacros.TokenParser, 

@@ -22,7 +22,26 @@  import UU.Pretty.Basic +prds = proc () -> do +         rec     root    <- addNT -<  (iI semAGItf exp Ii)+                 exp     <- addNT -<  (iI semLet "let" var  "=" exp "in" exp Ii) +                                      <|> +                                      (iI semAdd exp "+" term Ii)+                                      <|> +                                      iI id term Ii +                 term    <- addNT -<  (iI semMul term  "*"  factor Ii)+                                      <|>+                                      iI id factor Ii+                 factor  <- addNT -<  (iI semCst int Ii)+                                      <|> +                                      (iI semVar var Ii)++         exportNTs -< exportList root  $   export ntExp     exp +                                       .   export ntTerm    term +                                       .   export ntFactor  factor  ++{- prds = proc () -> do           rec     root    <- addNT -<  (iI (`semAGItf` emptyRecord) (ch_expr <=> exp) Ii)@@ -42,7 +61,7 @@          exportNTs -< exportList root  $   export ntExp     exp                                         .   export ntTerm    term                                         .   export ntFactor  factor  - +-}  {- -- another possible version prds = proc () -> do

@@ -13,7 +13,7 @@ import Language.Grammars.AspectAG.Derive  import Language.Grammars.SyntaxMacros-import Language.Grammars.Grammar+import Language.Grammars.Grammar hiding ((<=>))   import LangSem@@ -39,8 +39,11 @@                           (HCons (LVPair (Proxy Att_sval) Int) HNil))  ++ --Square-$(chLabel "se" ''T_Expr)+-- $(chLabel "se" ''T_Expr)+$(addProd "Sq" [ ("se",''T_Expr) ])  sppSq = synM spp $ do me1 <- at ch_se                        return $ "square" >#< (me1 # spp)   @@ -48,12 +51,16 @@ se2m r = (ch_me1 .=. (r # ch_se) .*. ch_me2 .=. (r # ch_se) .*. emptyRecord) m2se r = (ch_se .=. (r # ch_me1) .*. emptyRecord) -aspSq = sppSq `ext` (adapt aspMul se2m se2m m2se)-semSq = \s -> knit aspSq (s .*. emptyRecord)   +-- aspSq = sppSq `ext` (adapt aspMul se2m se2m m2se)+aspSq = sppSq `ext` (mapChildren aspMul (ch_me1 .=. ch_se .*. ch_me2 .=. ch_se .*. emptyRecord)) +-- semSq = \s -> knit aspSq (s .*. emptyRecord)  +semSq = semP_Sq aspSq+ --Pyth-$(chLabels ["pe1","pe2"] ''T_Expr)+-- $(chLabels ["pe1","pe2"] ''T_Expr)+$(addProd "Pyth" [ ("pe1",''T_Expr), ("pe2",''T_Expr) ])  sppSq' = synM spp $ do liftM (# spp) (at ch_se)  aspSq' = sppSq' `ext` aspSq @@ -61,23 +68,62 @@ 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_ae2 .=. ch_ae2 .*. emptyRecord)                           ch_ae1                            aspSq' -                          (ch_se .=. ch_pe1 .*. hNil))-                  (ch_pe1 .=. ch_pe1 .*. hNil)+                          (ch_se .=. ch_pe1 .*. emptyRecord))+                  (ch_pe1 .=. ch_pe1 .*. emptyRecord)                   ch_ae2                   aspSq' -                  (ch_se .=. ch_pe2 .*. hNil)+                  (ch_se .=. ch_pe2 .*. emptyRecord)+-} +aspAdd' =  agMacro  (aspAdd, ch_ae1 ==> (aspSq', ch_se --> ch_pe1)+                             <.> +                             ch_ae2 ==> (aspSq', ch_se --> ch_pe2))++ aspPyth    = sppPyth `ext` aspAdd'-semPyth = \p1 p2 -> knit  aspPyth (p1 .*. p2 .*. emptyRecord)  -                +-- semPyth = \p1 p2 -> knit  aspPyth (p1 .*. p2 .*. emptyRecord)  +semPyth = semP_Pyth aspPyth ++--AddSq+$(addProd "AddSq" [ ("as1",''T_Expr), ("as2",''T_Expr) ])+++sppAddSq  = synM spp  $ do  as1 <- at ch_as1+                            as2 <- at ch_as2 +                            return $ "addsq" >#< (as1 # spp) >#< (as2 # spp)   ++++{-+aspAddSq = sppAddSq `ext`+           (graft  (graft  aspMul+                           (ch_me2 .=. ch_me2 .*. emptyRecord)+                           ch_me1 +                           aspAdd +                           (ch_ae1 .=. ch_as1 .*. ch_ae2 .=. ch_as2 .*. emptyRecord))+                   (ch_as1 .=. ch_as1 .*. ch_as2 .=. ch_as2 .*. emptyRecord)+                   ch_me2+                   aspAdd +                   (ch_ae1 .=. ch_as1 .*. ch_ae2 .=. ch_as2 .*. emptyRecord))+-}++aspAddSq = sppAddSq `ext`+            agMacro  (aspMul   ,   ch_me1 ==> (aspAdd, ch_ae1 --> ch_as1 <.> ch_ae2 --> ch_as2)+                              <.>  ch_me2 ==> (aspAdd, ch_ae1 --> ch_as1 <.> ch_ae2 --> ch_as2))+++semAddSq = semP_AddSq aspAddSq++ --Parenthesis-$(chLabel "pe" ''T_Expr)+-- $(chLabel "pe" ''T_Expr)+$(addProd "Par" [ ("pe",''T_Expr) ])  sppPar  = syn spp  $ do  pe <- at ch_pe                          return $ "(" >|< pe # spp >|< ")" @@ -85,17 +131,17 @@ ienvPar = copy ienv exprNT  aspPar = sppPar `ext` ienvPar `ext` svalPar-   -semPar = \e -> knit aspPar (e .*. emptyRecord)+-- semPar = \e -> knit aspPar (e .*. emptyRecord)+semPar = semP_Par aspPar   --Substitution-sppSubst = synM spp $ do  lnm   <- at ch_lnm+sppSubst = synM spp $ do  lnm   <- valAt ch_lnm                           val   <- at ch_val                           body  <- at ch_body                           return $ (body # spp) >|< "[" >|< (pp lnm)  >|< " | " >|< (val # spp) >|< "]"  -semSubst = \l v b -> knit (sppSubst `ext` aspLet) (l .*. v .*. b .*. emptyRecord)+semSubst = \b l v -> semP_Let (sppSubst `ext` aspLet) l v b   @@ -111,12 +157,13 @@          let term    = getNT ntTerm    imported          let factor  = getNT ntFactor  imported -         addProds   -<  (exp,     ( iI semSubst  (ch_body <=> exp) "[" (ch_lnm <=> var) "|" (ch_val <=> exp) "]" Ii))+         addProds   -<  (exp,     ( iI semSubst  exp "[" var "|" exp "]" Ii)) -         addProds   -<  (term,    ( iI semSq     "square"  (ch_se  <=> factor) Ii) <|>-                                  ( iI semPyth   "pyth"    (ch_pe1 <=> factor) (ch_pe2 <=> factor) Ii))+         addProds   -<  (term,    ( iI semSq     "square"  factor Ii)  <|>+                                  ( iI semPyth   "pyth"    factor factor Ii) <|>+                                  ( iI semAddSq  "addsq"   factor factor Ii))  -         addProds   -<  (factor,  ( iI semPar    "(" (ch_pe <=> exp) ")" Ii )    )+         addProds   -<  (factor,  ( iI semPar    "(" exp ")" Ii )    )                    exportNTs  -< imported @@ -129,43 +176,55 @@ --Syntax Macro 2 --------------------------------------------------------------  --Double-$(chLabel "de" ''T_Expr)--aspTwo = fixCst aspCst ch_cv 2+-- $(chLabel "de" ''T_Expr)+$(addProd "Db" [ ("de",''T_Expr) ]) +--aspTwo = fixCst aspCst ch_cv 2+{- aspMul' =  graft  aspMul-                  (ch_me2 .=. ch_de .*. hNil) +                  (ch_me2 .=. ch_de .*. emptyRecord)                    ch_me1                   aspTwo-                  hNil +                  emptyRecord +-} +aspMul' =  agMacro  (aspMul   ,   ch_me1 ==> (aspCst, ch_cv ~~> (DTerm undefined 2))+                             <.>  ch_me2 --> ch_de)+                  + sppDb = synM spp $ do de <- at ch_de                        return $ "double" >#< (de # spp)     aspDb = sppDb `ext` aspMul'                 -semDb = \d -> knit aspDb (d .*. emptyRecord)-+--semDb = \d -> knit aspDb (d .*. emptyRecord)+semDb = semP_Db aspDb               --AddMul-$(chLabels ["am1","am2","am3"] ''T_Expr)+-- $(chLabels ["am1","am2","am3"] ''T_Expr)+$(addProd "AddMul" [ ("am1",''T_Expr), ("am2",''T_Expr), ("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_ae1 .=. ch_am1 .*. emptyRecord)                                     ch_ae2                                      aspMul-                                    (ch_me1 .=. ch_am2 .*. ch_me2 .=. ch_am3 .*. hNil)+                                    (ch_me1 .=. ch_am2 .*. ch_me2 .=. ch_am3 .*. emptyRecord)+-}+aspAddMul = sppAddMul `ext`+            agMacro  (aspAdd   ,  ch_ae1 --> ch_am1+                              <.> ch_ae2 ==> (aspMul, ch_me1 --> ch_am2 <.> ch_me2 --> ch_am3))+  -semAddMul = \p1 p2 p3 -> knit aspAddMul (p1 .*. p2 .*. p3 .*. emptyRecord)-                          +-- semAddMul = \p1 p2 p3 -> knit aspAddMul (p1 .*. p2 .*. p3 .*. emptyRecord)+semAddMul = semP_AddMul aspAddMul                             --Grammar Extension@@ -179,8 +238,8 @@          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))+         addProds   -<  (term,     (iI semDb      "double"  factor Ii) <|>+                                   (iI semAddMul  "addmul"  factor factor factor Ii))                     exportNTs  -< imported

@@ -1,3 +1,4 @@+{-# OPTIONS -fcontext-stack=100 #-} {-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction #-}  module LangSem where@@ -15,6 +16,8 @@  import Control.Monad  +import Language.Grammars.Grammar (DTerm(..))+ data AGItf = AGItf { expr :: T_Expr}           deriving Show @@ -29,7 +32,10 @@  syn = syndefM inh = inhdefM+valAt = liftM value . at+posAt = liftM pos . at + $(deriveAG ''AGItf)  exprNT = nt_T_Expr .*. hNil@@ -40,8 +46,8 @@ $(attLabels ["spp"])  sppAGItf  = syn spp $ liftM (# spp) (at ch_expr)-sppCst    = syn spp $ liftM pp      (at ch_cv)-sppVar    = syn spp $ liftM pp      (at ch_vnm)+sppCst    = syn spp $ liftM pp      (valAt ch_cv)+sppVar    = syn spp $ liftM pp      (valAt ch_vnm) sppMul    = syn spp $ do  e1 <- at ch_me1                            e2 <- at ch_me2                           return $ e1 # spp >|< " * " >|< e2 # spp @@ -49,7 +55,7 @@                           e2 <- at ch_ae2                           return $ e1 # spp >|< " + " >|< e2 # spp  -sppLet    = syn spp $ do  lnm  <- at ch_lnm+sppLet    = syn spp $ do  lnm  <- valAt ch_lnm                           val  <- at ch_val                           body <- at ch_body                           return $ "let " >|< pp lnm >|< " = " >|< val # spp >|< " in " >|< body # spp    @@ -64,7 +70,7 @@ ienvVar   = ienvRule ienvMul   = ienvRule ienvAdd   = ienvRule-ienvLet   = inh ienv exprNT $ do lnm <- at ch_lnm+ienvLet   = inh ienv exprNT $ do lnm <- valAt ch_lnm                                  val <- at ch_val                                  lhs <- at lhs                                  return  $  ch_val   .=.  lhs # ienv .*.@@ -74,8 +80,8 @@  svalRule  f = use sval allNT f  (0::Int)   svalAGItf = svalRule ((*)::Int->Int->Int)-svalCst   = syn sval $ liftM id (at ch_cv)-svalVar   = syn sval $ do  vnm <- at ch_vnm +svalCst   = syn sval $ liftM id (valAt ch_cv)+svalVar   = syn sval $ do  vnm <- valAt ch_vnm                             lhs <- at lhs                            return $ fromJust (lookup vnm (lhs # ienv))  svalMul   = svalRule ((*)::Int->Int->Int)@@ -91,11 +97,11 @@ aspLet   = sppLet   `ext` ienvLet   `ext` svalLet  -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)+semAGItf  = semP_AGItf aspAGItf +semCst    = semP_Cst aspCst +semVar    = semP_Var aspVar +semMul    = semP_Mul aspMul+semAdd    = semP_Add aspAdd+semLet    = semP_Let aspLet   

@@ -10,43 +10,54 @@ import LangExt  import Language.Grammars.SyntaxMacros-import Language.Grammars.SyntaxMacros.Scanner+import Language.Grammars.SyntaxMacros.UUParsing  import Language.Grammars.AspectAG   gram = closeGram prds+test1 = lang1 "prog.src"+lang1 s = do+--        tokens <- scanFile gramOpts "prog.src"+        tokens <- readFile s -test1 = do-        tokens <- scanFile gramOpts "prog.src"         let r = (parse . compile ) gram tokens          case ( parse . compile ) gram tokens of-           (Ok res) -> do print $ res # spp+           (Ok fres) -> do +                          let res = fres emptyRecord+                          print $ res # spp                           print $ res # sval            (Rep _ err) -> print err    -gram' = closeGram (prds <++> prds') --test2 = do-        tokens <- scanFile (gramOpts' gramOpts) "prog2.src"+gram' = closeGram (prds +>> prds') +test2 = lang2 "prog2.src"+lang2 s = do+--        tokens <- scanFile (gramOpts' gramOpts) "prog2.src"+        tokens <- readFile s         case ( parse . compile ) gram' tokens of-           (Ok res) -> do print $ res # spp+           (Ok fres) -> do +                          let res = fres emptyRecord+                          print $ res # spp                           print $ res # sval            (Rep _ err) -> print err -gram'' = closeGram (prds <++> prds' <++> prds'') --test3 = do-        tokens <- scanFile ((gramOpts'' . gramOpts') gramOpts) "prog3.src"+gram'' = closeGram (prds +>> prds' +>> prds'') +test3 = lang3 "prog3.src"+lang3 s = do+--        tokens <- scanFile ((gramOpts'' . gramOpts') gramOpts) "prog3.src"+        tokens <- readFile s         case ( parse . compile ) gram'' tokens of-           (Ok res) -> do print $ res # spp+           (Ok fres) -> do +                          let res = fres emptyRecord+                          print $ res # spp                           print $ res # sval            (Rep _ err) -> print err   main = test1 >> test2 >> test3+ 

@@ -1,1 +1,1 @@-let letter= 2 + 10 in 3 * letter + 104+let letter = 2 + 10 in letter * 104

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

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

binary file changed (24576 → absent bytes)

@@ -7,7 +7,6 @@ import Data.HList  import Control.Applicative-import Unsafe.Coerce   -------------------------------------------@@ -16,45 +15,67 @@  data TL data FL a+data NF   data Grammar a     = forall env . Grammar  (Ref a env)  -                          (GramEnv env env)+                          (FinalEnv (Productions NF) env) -type GramEnv = Env (Productions TL)  newtype Productions l a env    = PS {unPS :: [Prod l a env]}  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+      Star      ::  Prod l (a->b) env -> Prod l  a      env +                ->  Prod l b  env+      FlipStar  ::  Prod NF a     env -> Prod NF (a->b) env +                ->  Prod NF 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 +      Fix       ::  Productions (FL a) a env               +                ->  Prod TL     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 +type GramEnv = Env (Productions NF)+type PreGramEnv = Env (Productions TL)+++newtype PreProductions l env a +  = PP {unPP :: [Prod l a env]}+++type Line      = Int+type Column    = Int+type Filename  = String++data Pos  =  Pos      !Line !Column +          |  PosFile  !Line !Column Filename+  deriving Show++data DTerm a = DTerm {pos :: Pos, value :: a}+ data TTerm data TNonT data TAttT  data Symbol a t env where-  Term    :: String    ->  Symbol  DTerm    TTerm   env+  Term    :: String    ->  Symbol  (DTerm String)    TTerm   env -  Nont    :: Ref a env ->  Symbol  a        TNonT   env+  Nont    :: Ref a env ->  Symbol  a                 TNonT   env   -- attributed terminals-  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 +  TermInt   ::             Symbol  (DTerm Int)       TAttT   env+  TermChar  ::             Symbol  (DTerm Char)      TAttT   env+  TermVarid ::             Symbol  (DTerm String)    TAttT   env+  TermConid ::             Symbol  (DTerm String)    TAttT   env+  TermOp    ::             Symbol  (DTerm String)    TAttT   env    --- TODO: the rest of EnumValToken  @@ -77,11 +98,11 @@ matchSym _          _                    = Nothing  -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   ::  Symbol (DTerm Int)     TAttT  env+char  ::  Symbol (DTerm Char)    TAttT  env+var   ::  Symbol (DTerm String)  TAttT  env+con   ::  Symbol (DTerm String)  TAttT  env+op    ::  Symbol (DTerm String)  TAttT  env  int   =  TermInt char  =  TermChar@@ -94,45 +115,42 @@ -- 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  ::  Symbol a  t  env -> PreProductions l env a sym  s = PP [ Sym $ s ] -nt :: Symbol a  TNonT  env -> ListProd l env a+nt :: Symbol a  TNonT  env -> PreProductions l env a nt s = sym s -ntPrd :: Symbol a  TNonT  env -> ListProd l env a+ntPrd :: Symbol a  TNonT  env -> PreProductions l env a ntPrd s =  id <$> nt s   -tr ::  String -> ListProd l env DTerm+tr ::  String -> PreProductions l env (DTerm String) tr s = PP [ Sym $ Term s ]  -varPrd   ::  ListProd (FL a) env a+prod :: PreProductions l env a -> Productions l a env+prod (PP ps) = PS ps++varPrd   ::  PreProductions (FL a) env a varPrd    = PP [ Var ]-fixPrd  ::  ListProd (FL a) env a -> ListProd l env a+fixPrd  ::  PreProductions (FL a) env a -> PreProductions TL env a fixPrd p  = PP [ (Fix . prod) p ]  -instance Functor (ListProd l env) where+instance Functor (PreProductions l env) where  fmap f (PP p) = PP [ Star (Pure f) p' | p' <- p ] -instance Applicative (ListProd l env) where+instance Applicative (PreProductions 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+instance Alternative (PreProductions 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@@ -142,7 +160,7 @@      where  none = pure []              more = (:)   <$> toFL p <*> varPrd -toFL :: ListProd l env a -> ListProd (FL b) env a+toFL :: PreProductions l env a -> PreProductions (FL b) env a toFL (PP p) = PP $ map prodToFL p  prodToFL :: Prod l a env -> Prod (FL b) a env@@ -151,46 +169,89 @@ 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-+prodToFL Var               = error "ERROR: Language.Grammars.Grammar:1"+-} -pSome :: ListProd (FL [a]) env a -> ListProd l env [a]+pSome :: PreProductions (FL [a]) env a -> PreProductions TL env [a] pSome p = fixPrd (one <|> more)      where  one  = (:[]) <$> p              more = (:)   <$> p <*> varPrd -pMany :: ListProd (FL [a]) env a -> ListProd l env [a]+pMany :: PreProductions (FL [a]) env a -> PreProductions TL env [a] pMany p = fixPrd (none <|> more)      where  none = pure []              more = (:)   <$> p <*> varPrd+{-+pMaybe :: PreProductions l env a -> PreProductions l env (Maybe a)+pMaybe p = (nothing <|> just)+     where  nothing = pure Nothing +            just    = Just   <$> p   +pEither :: PreProductions l env a -> PreProductions l env b -> PreProductions l env (Either a b)+pEither p q = (left <|> right)+     where  left  = Left  <$> p+            right = Right <$> q +-}++opt :: PreProductions l env a -> a -> PreProductions l env a+opt p a = p <|> pure a++pMaybe :: (b, (a -> b)) -> PreProductions TL env a -> PreProductions TL env b+pMaybe (n, j) p = (nothing <|> just)+     where  nothing = pure n +            just    = j  <$> p +++pFoldr :: (a -> b -> b, b) -> PreProductions (FL b) env a -> PreProductions TL env b+pFoldr (c, e) p = fixPrd (none <|> more)+     where  none = pure e +            more = c   <$> p <*> varPrd+ ------------------------ -- IDIOMS --- | The  `Ii` is to be pronounced as @stop@+-- | The  'Ii' is to be pronounced as @stop@ data Ii = Ii  --- | The function `iI` is to be pronounced as @start@+-- | 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+    idiomatic :: PreProductions l env f -> g -instance  Idiomatic l env x  (Ii -> ListProd l env x) where+instance  Idiomatic l env x  (Ii -> PreProductions 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+++instance  Idiomatic l env f g  => Idiomatic  l env (a -> f) (PreProductions l env a -> g) where     idiomatic isf is = idiomatic (isf <*> is) +instance  Idiomatic l env f g  => Idiomatic  l env (a -> f) (Symbol a TNonT env -> g) where+    idiomatic isf is = idiomatic (isf <*> (sym is))++instance  Idiomatic l env f g  => Idiomatic  l env ((Record HNil -> a) -> f) (Symbol a TAttT env -> g) where+    idiomatic isf is = idiomatic (isf <*> ((\x (Record HNil) -> x) <$> (sym is :: PreProductions l env a)))++ instance Idiomatic l env f g => Idiomatic l env ((a -> b) -> f)  ((a -> b) -> g) where-    idiomatic isf f = idiomatic (isf <*> (pure f))+    idiomatic isf f = idiomatic (isf <*> (pure f :: PreProductions l env (a->b)))  instance (Idiomatic  l env f g)         => Idiomatic  l env f (String -> g) where     idiomatic isf str = idiomatic (isf <* (tr str)) +{-+data Pos = Pos String +pt :: String -> Pos+pt = Pos++instance  Idiomatic l env f g  => Idiomatic  l env ((Record HNil -> DTerm String) -> f) (Pos -> g) where+    idiomatic isf (Pos is) = idiomatic (isf <*> ((\x (Record HNil) -> x) <$> (tr is)))+-}+ -------------------------------------------------------------------------------  @@ -206,20 +267,20 @@ infixr 6 <=>  class LabelSymbol t v v' | t v -> v' where - (<=>) :: label -> Symbol v t env -> ListProd l env (LVPair label v')+ (<=>) :: label -> Symbol v t env -> PreProductions l env (LVPair label v')   instance LabelSymbol TAttT v (Record HNil -> v) where- l <=> v =  (\x -> l .=. (\(Record HNil) -> x)) <$> (PP [ Sym v ])+ l <=> v =  (\x -> l .=. (\(Record HNil) -> x)) <$> (sym v)  instance LabelSymbol TNonT v v where- l <=> v =  (l .=.) <$> (PP [ Sym v ])+ l <=> v =  (l .=.) <$> (sym v)  instance LabelSymbol TTerm v v where -- only to have all the instances- l <=> v =  (l .=.) <$> (PP [ Sym v ])-+ l <=> v =  (l .=.) <$> (sym v)  +{- ------------------------------------------------------------------------------- -- Show instances for the Grammars -- Just for debugging purposes@@ -260,4 +321,4 @@ instance Show (Ref a env) where  show Zero     = "0"  show (Suc r)  = show  $ (1::Int) + ((read . show) r)-+-}

@@ -1,5 +1,6 @@ {-# LANGUAGE Arrows, ExistentialQuantification, GADTs, Rank2Types, FlexibleContexts, ScopedTypeVariables     , EmptyDataDecls, MultiParamTypeClasses, FlexibleInstances, OverlappingInstances, FunctionalDependencies, UndecidableInstances+    , NoMonomorphismRestriction   #-}  module Language.Grammars.SyntaxMacros where@@ -7,33 +8,32 @@ import Language.AbstractSyntax.TTTAS import Control.Arrow -import qualified UU.Parsing as UU-import Language.Grammars.SyntaxMacros.Scanner- import Language.Grammars.Grammar  import Language.Grammars.Transformations.RemoveFix import Language.Grammars.Transformations.RemoveEmpties import Language.Grammars.Transformations.LeftCorner  -type GramTrafo = Trafo Unit (Productions TL)+type GramTrafo    = Trafo Unit (Productions NF)+type PreGramTrafo = Trafo Unit (Productions TL)+ type ExtGram      env  start  nts   -           = GramTrafo env  ()   (Export start nts env)+           = PreGramTrafo env  ()   (Export start nts env) type SyntaxMacro  env  start  nts  start' nts'  -           = GramTrafo env  (Export start nts env)  (Export start' nts' env)+           = PreGramTrafo 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 (ListProd TL env a) (Symbol a TNonT env)+addNT  ::  PreGramTrafo env (PreProductions TL env a) (Symbol a TNonT env) addNT  =  proc  p -> do                  r  <- newSRef -< prod p                 returnA -< Nont r   -- add productions to an existing non-terminal-addProds  ::  GramTrafo  env -                         (Symbol a TNonT env, ListProd TL env a) ()+addProds  ::  PreGramTrafo  env +                         (Symbol a TNonT env, PreProductions TL env a) () addProds  = proc (nont, prds) -> do       updateFinalEnv  -<           updateEnv (\ps -> PS $ (unPP prds) ++ (unPS ps)) (getRefNT nont)@@ -44,25 +44,44 @@                 -> Grammar a  closeGram prds  = case runTrafo prds Unit () of      Result _ (Export (Nont r) _) gram -            -> (leftCorner . removeEmpties . removeFix) $ Grammar r gram+            -> (leftCorner . removeEmpties) (removeFix r gram) +-- extend a grammar extendGram  ::  (NTRecord (nts env), NTRecord (nts' env))               =>  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))  ++(+>>)      ::  (NTRecord (nts env), NTRecord (nts' env))               =>  ExtGram env start nts                  -> SyntaxMacro env start nts start' nts'                  -> ExtGram env start' nts' -(<++>) = extendGram+(+>>) = extendGram -exportNTs ::  NTRecord (nts env) => GramTrafo env (Export start nts env) (Export start nts env)++-- export+exportNTs ::  NTRecord (nts env) => PreGramTrafo env (Export start nts env) (Export start nts env) exportNTs = returnA +-- compose grammars+{-+compG  ::  (NTUnion nts1 nts2 nts)+       =>  ExtGram env start nts1+       ->  ExtGram env start nts2+       ->  ExtGram env start nts +compG g1 g2 =  proc  () -> do+                (Export s1 ns1) <- g1 -< ()+                (Export s2 ns2) <- g2 -< ()+ +                s  <- addNT -< iI s1 Ii <|> iI s2 Ii++                returnA -< Export s (ntUnion ns1 ns2)+-}+ -- extensible record  @@ -119,82 +138,7 @@         -> l env ->  NTCons nt a l env export l nont = (^|) (l ^= nont)  --- COMPILE -------------------------------------------------------------------- -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 UU.<$> pChar-pInt            =    read UU.<$> pInteger-pCon            =    id UU.<$> pConid-pVar            =    id UU.<$> pVarid-pOp             =    id UU.<$> pVarsym--pTerm           ::  (UU.IsParser p Token) -                =>  String -> p DTerm-pTerm t         =   pKey t--newtype Const f a s = C {unC :: f 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 (UU.<|>) [ comp p | p <- ps]))-          rules--         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-mapEnv  f (Ext r v)   = Ext (mapEnv f r) (f v)----- PARSE ------------------------------------------------------------------------type ParseMsg = UU.Message Token (Maybe Token)--data ParseResult a = Ok  a-                   | Rep a [ParseMsg] -      deriving Show--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 :: 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 :: 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,[]) +extendExport :: Export start t env -> (t env -> nts env) -> Export start nts env+extendExport (Export r nts) ext = Export r (ext nts) 

@@ -3,7 +3,7 @@ import Data.Char import Data.List import Data.Maybe-import IO+import System.IO import UU.Scanner.Position import qualified Data.Set as Set 

@@ -14,7 +14,7 @@   )   where -import IO+import System.IO import Data.Char import Data.List import qualified Data.Set as Set

@@ -0,0 +1,90 @@+module Language.Grammars.SyntaxMacros.UULib where++import qualified UU.Parsing as UU+import Language.Grammars.SyntaxMacros.Scanner hiding (Pos)+import qualified Language.Grammars.SyntaxMacros.Scanner as S++import Language.Grammars.Grammar+import Language.AbstractSyntax.TTTAS++toPos :: S.Pos -> Pos+toPos (S.Pos l c f) = PosFile l c f++toDTerm :: (a -> b) -> (a, S.Pos) -> DTerm b+toDTerm f p =  DTerm ((toPos . snd) p) ((f . fst) p)++pChr            ::   UU.Parser Token (DTerm Char)+pChr            =    (toDTerm head) UU.<$> pCharPos+pInt            ::   UU.Parser Token (DTerm Int)+pInt            =    (toDTerm read) UU.<$> pIntegerPos+pCon            ::   UU.Parser Token (DTerm String)+pCon            =    (toDTerm id)   UU.<$> pConidPos+pVar            ::   UU.Parser Token (DTerm String)+pVar            =    (toDTerm id)   UU.<$> pVaridPos+pOp             ::   UU.Parser Token (DTerm String)+pOp             =    (toDTerm id)   UU.<$> pVarsymPos++pTerm           ::  (UU.IsParser p Token) +                =>  String -> p (DTerm String)+pTerm t         =   (toDTerm id . (\loc -> (t,loc)))  UU.<$> pKeyPos t++newtype Const f a s = C {unC :: f 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 (UU.<|>) [ comp p | p <- ps]))+          rules++         comp :: forall t . Prod NF 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+++mapEnv  ::  (forall a . f a s -> g a s)  +        ->  Env f s env -> Env g s env+mapEnv  _ Empty       = Empty+mapEnv  f (Ext r v)   = Ext (mapEnv f r) (f v)+++-- PARSE ----------------------------------------------------------------------++type ParseMsg = UU.Message Token (Maybe Token)++data ParseResult a = Ok  a+                   | Rep a [ParseMsg] +      deriving Show++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 :: 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 :: 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,[]) +

@@ -0,0 +1,84 @@+module Language.Grammars.SyntaxMacros.UUParsing where+++import qualified Text.ParserCombinators.UU.Core as UU+import Text.ParserCombinators.UU+import Text.ParserCombinators.UU.Utils+import Text.ParserCombinators.UU.BasicInstances hiding (Parser,input,msgs)++import Language.Grammars.Grammar+import Language.AbstractSyntax.TTTAS+++type Parser a = P (Str Char String LineCol) a++pInt :: Parser Int+pInt  = pInteger+pChr :: Parser Char+pChr  = pAscii++pVar :: Parser String+pVar  = ((:) <$> pLower <*> pList pIdChar `micro` 2) <* spaces ++pCon :: Parser String+pCon  = ((:) <$> pUpper <*> pList pIdChar `micro` 2) <* spaces++pIdChar :: Parser Char+pIdChar = pLower <|> pUpper <|> pDigit <|> pAnySym "='"++pOp :: Parser String+pOp   = (pList1 $ pAnySym ('|':"!#$%&*+./<=>?@\\^-~:") `micro` 2) <* spaces++pTerm :: String -> Parser String+pTerm keyw = pToken keyw `micro` 1 <* spaces+spaces :: Parser String+spaces = pMunch (`elem` " \n")++lc2Pos :: LineCol -> Pos+lc2Pos (LineCol l c) = Pos l c++newtype Const f a s = C {unC :: f a}++-- | The function 'compile' generates a parser out of a closed grammar +compile :: Grammar a -> Parser a+compile (Grammar (start :: Ref a env) rules) +                       = unC (lookupEnv start result)+  where  result  =  +          mapEnv +          (\ (PS ps) -> C (foldr1 (<|>) [ comp p | p <- ps]))+          rules++         comp :: forall t . Prod NF t env -> Parser t++         comp (Star     x y)   = comp x <*>   comp y+         comp (FlipStar x y)   = comp x <**>  comp y+         comp (Pure     x)     = pure x++         comp (Sym (Term t))   = (DTerm . lc2Pos) <$> pPos <*> pTerm t+         comp (Sym (Nont n))   = unC (lookupEnv n result)++         comp (Sym TermInt)    = (DTerm . lc2Pos) <$> pPos <*> pInt+         comp (Sym TermChar)   = (DTerm . lc2Pos) <$> pPos <*> pChr+         comp (Sym TermVarid)  = (DTerm . lc2Pos) <$> pPos <*> pVar+         comp (Sym TermConid)  = (DTerm . lc2Pos) <$> pPos <*> pCon+         comp (Sym TermOp)     = (DTerm . lc2Pos) <$> pPos <*> pOp+++mapEnv  ::  (forall a . f a s -> g a s)  +        ->  Env f s env -> Env g s env+mapEnv  _ Empty       = Empty+mapEnv  f (Ext r v)   = Ext (mapEnv f r) (f v)++++data ParseResult a = Ok  a+                   | Rep a [Error LineCol] +      deriving Show++-- | The function 'parse' runs the parser for an input.+parse :: Parser a -> String -> ParseResult a+parse p input = case UU.parse ( (,) <$> p <*> pEnd) (createStr (LineCol 0 0) input) of+                  (a,[]  ) -> Ok a+                  (a,msgs) -> Rep a msgs++

@@ -30,11 +30,11 @@                    -type GramTrafo env a = Trafo (MapA_X env a) (Productions TL)+type GramTrafo env a = Trafo (MapA_X env a) (Productions NF)   initMap :: GramTrafo env a s c d-        -> Trafo Unit (Productions TL) s c d+        -> Trafo Unit (Productions NF) s c d initMap (Trafo st)          = Trafo (\_ -> case st emptyMap of                             TrafoE _ f -> TrafoE Unit f@@ -42,12 +42,12 @@  newNontRS  ::  forall x t env s a             .   Symbol (x->a) t env -           ->  GramTrafo env a s (Productions TL x s) (Ref x s)+           ->  GramTrafo env a s (Productions NF 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)+           ->  GramTrafo env a s (Productions NF (x->a) s) (Ref (x->a) s) newNontRF x = Trafo $ \m -> extEnv (extendMapF x m)  @@ -59,7 +59,7 @@      = T (flip lookupEnv env)  -mapProd  :: T env1 env2 -> Prod l a env1 -> Prod l a env2+mapProd  :: T env1 env2 -> Prod NF a env1 -> Prod NF a env2 mapProd t (Sym (Nont x))      = Sym (Nont (unT t x))  mapProd _ (Sym (Term x))      = Sym  (Term x)  mapProd _ (Sym TermInt)       = Sym TermInt @@ -70,6 +70,4 @@ 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 

@@ -15,7 +15,7 @@                  Grammar (tt start) gram  lctrafo :: GramEnv env env -        -> Trafo Unit (Productions TL) s () (T env s)+        -> Trafo Unit (Productions NF) s () (T env s) lctrafo productions = proc _ ->             do   rec  let tenv_s = map2trans menv_s                       menv_s <- (rules1 productions productions) -< tenv_s@@ -24,7 +24,7 @@  rules1  ::  GramEnv env env         ->  GramEnv env env' -        ->  Trafo  Unit (Productions TL) s (T env s) +        ->  Trafo  Unit (Productions NF) s (T env s)                                             (Mapping env' s) rules1 _ Empty                = proc _ ->@@ -39,16 +39,16 @@   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)+          -> [Prod NF a env]+          -> Trafo Unit (Productions NF) s (T env s) (Productions NF a s) app_rule1 productions prods =  initMap            ( proc tenv_s ->                  do pss <- sequenceA  (map  (rule1 productions . accessLeftMost) prods) -< tenv_s                     returnA -< PS (concatMap unPS pss)           ) -rule1  :: GramEnv env env -> Prod TL a env -       -> GramTrafo env a s (T env s) (Productions TL a s)+rule1  :: GramEnv env env -> Prod NF a env +       -> GramTrafo env a s (T env s) (Productions NF a s)  rule1 gram (Star (Sym x) beta)       = proc tenv_s ->@@ -67,7 +67,7 @@      = error "Left-Corner(2): error in the transformation!!!"  -accessLeftMost :: Prod TL a env -> Prod TL a env+accessLeftMost :: Prod NF a env -> Prod NF 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) @@ -81,7 +81,7 @@ rule2S  :: GramEnv env env          -> Symbol (x->a) t env          -> GramTrafo env a s (T env s, Ref x s) -                             (Productions TL a s)+                             (Productions NF a s) rule2S gram (Nont b)       = case lookupEnv b gram of           PS ps ->  proc (tenv_s, a_x) ->@@ -92,9 +92,9 @@   rule2bS  :: GramEnv env env -         -> Prod TL (b->a) env +         -> Prod NF (b->a) env           -> GramTrafo env a s (T env s, Ref b s) -                              (Productions TL a s)+                              (Productions NF a s)  rule2bS gram (Star (Sym x) beta)       = proc (tenv_s, a_b) ->@@ -118,7 +118,7 @@ rule2F  :: GramEnv env env          -> Symbol x t env          -> GramTrafo env a s (T env s, Ref (x->a) s) -                             (Productions TL a s)+                             (Productions NF a s) rule2F _    (Term a)       = proc (_, a_x) ->         do  returnA -< PS [rule2aF a a_x]@@ -145,20 +145,20 @@         do  returnA -< PS [rule2a'F TermOp a_x]  -rule2a'F :: Symbol a t s -> Ref (a->b) s -> Prod TL b s+rule2a'F :: Symbol a t s -> Ref (a->b) s -> Prod NF b s rule2a'F s refA_a      =  FlipStar (Sym s) (Sym $ Nont refA_a) -- (flip ($)) <$> (Sym s) <*> nont refA_a  -rule2aF :: String -> Ref (DTerm -> a) s -> Prod TL a s+rule2aF :: String -> Ref (DTerm String -> a) s -> Prod NF a s rule2aF a refA_a      =  FlipStar (Sym $ Term a) (Sym $ Nont refA_a) -- (flip ($)) <$> term a <*> nont refA_a   rule2bF  :: GramEnv env env -         -> Prod TL b env +         -> Prod NF b env           -> GramTrafo env a s (T env s, Ref (b -> a) s) -                              (Productions TL a s)+                              (Productions NF a s)  rule2bF gram (Star (Sym x) beta)       = proc (tenv_s, a_b) ->@@ -180,8 +180,8 @@ 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)+        ->  GramTrafo env a s  (T env s, Prod NF x s)+                               (Productions NF a s) insertS gram x =       Trafo (            \(MapA_X ms mf) -> case ms x of@@ -199,8 +199,8 @@ 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)+        ->  GramTrafo env a s  (T env s, Prod NF (x->a) s)+                               (Productions NF a s) insertF gram x =       Trafo (            \(MapA_X ms mf) -> case mf x of@@ -216,8 +216,7 @@   extendA_X  :: m env2 -> Ref x env2 -            -> TrafoE m (Productions TL) s env2 (t, Prod TL x s) (Productions TL a env)+            -> TrafoE m (Productions NF) s env2 (t, Prod NF x s) (Productions NF a env) extendA_X m r = fmap  (const $ PS []) $                         updateSRef m r (\(_,p) (PS ps) -> PS (p:ps))- 

@@ -6,8 +6,8 @@ import Language.AbstractSyntax.TTTAS  -data HasEmpty a env = Unknown | HasEmpty (Prod TL a env) | HasNotEmpty- deriving (Show)+data HasEmpty a env = Unknown | HasEmpty (Prod NF a env) | HasNotEmpty+--  deriving (Show)   removeEmpties :: Grammar a -> Grammar a@@ -41,7 +41,7 @@     = error "RemoveEmpties(2): Error in the transformation!!!"          -updateEmpty :: Env HasEmpty use use -> (Productions TL) a use -> HasEmpty a use  +updateEmpty :: Env HasEmpty use use -> Productions NF a use -> HasEmpty a use               -> (HasEmpty a use, Bool, Bool)  updateEmpty _       _   (HasEmpty p) = (HasEmpty p,  False, False) updateEmpty _       _   HasNotEmpty  = (HasNotEmpty, False, False)@@ -49,7 +49,7 @@                                         Unknown -> (Unknown, False, True)                                         e       -> (e,       True,  False) -hasEmpty :: Env HasEmpty env env -> (Productions TL) a env -> HasEmpty a env+hasEmpty :: Env HasEmpty env env -> Productions NF a env -> HasEmpty a env hasEmpty empties (PS ps)= foldr (\p re -> combHasEmpty (isEmpty p empties) re) HasNotEmpty ps  @@ -62,7 +62,7 @@ combHasEmpty Unknown          _                = Unknown  -isEmpty :: Prod TL a env -> Env HasEmpty env env -> HasEmpty a env+isEmpty :: Prod NF a env -> Env HasEmpty env env -> HasEmpty a env isEmpty (Pure a)              _       = HasEmpty (Pure a) isEmpty (Sym (Term _))        _       = HasNotEmpty isEmpty (Sym (TermInt))       _       = HasNotEmpty@@ -94,7 +94,6 @@                                                                 HasNotEmpty        -> HasNotEmpty                                                                 _                  -> Unknown -isEmpty (Fix _)               _       = error "RemoveEmpties(8): cannot transform grammars with Fix constructions."   @@ -105,7 +104,7 @@     = Ext (removeEmptiesEnv empties rprds) (removeEmpty empties prds)  -removeEmpty :: Env HasEmpty env env -> Productions TL a env -> Productions TL a env+removeEmpty :: Env HasEmpty env env -> Productions NF a env -> Productions NF a env removeEmpty empties (PS prds) = PS $ foldr ((++) . remEmptyProd) [] prds    where       -- if we don't allow the starting point to be empty, @@ -114,7 +113,7 @@                         in  prd'  -splitEmpty :: Env HasEmpty env env -> Prod TL a env -> ([Prod TL a env], Maybe (Prod TL a env))+splitEmpty :: Env HasEmpty env env -> Prod NF a env -> ([Prod NF a env], Maybe (Prod NF a env))  splitEmpty  empties  (Star f g)       =  let (fne, fe) = splitEmpty empties f @@ -140,15 +139,14 @@     = 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!!!"+              _                  -> ([Sym $ Nont r], Nothing)+--              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."  

@@ -9,22 +9,23 @@  import Control.Arrow -removeFix :: forall a . Grammar a -> Grammar a-removeFix (Grammar start productions)++removeFix :: forall env a. Ref a env -> PreGramEnv env env -> Grammar a+removeFix 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 :: PreGramEnv env env +        -> Trafo Unit (Productions NF) 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) +remfixProds  ::  PreGramEnv env env' +             ->  Trafo  Unit (Productions NF) s (T env s)                                                  (Mapping env' s) remfixProds Empty                = proc _ ->@@ -39,13 +40,12 @@   -remfixProd  :: Prod l a env -            -> Trafo Unit (Productions TL) s (T env s) (Prod l a s)+remfixProd  :: Prod TL a env +            -> Trafo Unit (Productions NF) s (T env s) (Prod NF 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')     +        do  rec  r   <- newSRef -<  PS (map (remVar r tenv_s) ps)                  returnA -< (Sym $ Nont r)  remfixProd (Star f g) @@ -53,26 +53,34 @@         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 +-}+remfixProd (Sym s)       = proc tenv_s ->-        do  returnA -< mapProd tenv_s p+        do  returnA -< Sym $ mapSym tenv_s s +remfixProd (Pure x) +     = proc _ ->+        do  returnA -< Pure x  -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!!!"+mapSym :: T env1 env2 -> Symbol a t env1 -> Symbol a t env2+mapSym t (Nont x)      = Nont (unT t x)+mapSym _ (Term x)      = Term x+mapSym _ TermInt       = TermInt +mapSym _ TermChar      = TermChar +mapSym _ TermVarid     = TermVarid +mapSym _ TermConid     = TermConid +mapSym _ TermOp        = TermOp  +remVar  :: Ref b s -> T env s -> Prod (FL b) a env -> Prod NF a s+remVar _  t  (Sym s)             = Sym $ mapSym t s +remVar _  _  (Pure x)            = Pure x+remVar r  t  (Star f g)          = Star (remVar r t f) (remVar r t g)+remVar r  _  Var                 = Sym (Nont r)