SyntaxMacros 0.1 → 0.2

raw patch · 15 files changed

+412/−362 lines, 15 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• SyntaxMacros.cabal +1/−1
• examples/Expr.hs +0/−189
• examples/LangDef.hs +48/−0
• examples/LangExt.hs +103/−0
• examples/LangSem.hs +101/−0
• examples/Main.hs +6/−75
• examples/README.txt +9/−0
• examples/Utils.hs +33/−0
• examples/test +5/−0
• pru.hs +11/−0
• src/Language/Grammars/Grammar.hs +70/−75
• src/Language/Grammars/SyntaxMacros.hs +13/−10
• src/Language/Grammars/Transformations/GramTrafo.hs +4/−4
• src/Language/Grammars/Transformations/LeftCorner.hs +4/−4
• src/Language/Grammars/Transformations/LeftFact.hs +4/−4

@@ -1,5 +1,5 @@ name:               SyntaxMacros -version:            0.1+version:            0.2 license:            LGPL license-file:       COPYRIGHT maintainer:         Marcos Viera <mviera@fing.edu.uy>

@@ -1,189 +0,0 @@-{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction - , GADTs #-}--module Expr where--import Language.Grammars.AspectAG-import Language.Grammars.AspectAG.Derive--import Data.HList.Label4-import Data.HList.TypeEqGeneric1-import Data.HList.TypeCastGeneric1--import Data.Maybe--import UU.Pretty--import Control.Monad --data AGItf = AGItf { expr :: T_Expr}-          deriving Show--data T_Expr  =  Cst {cv  :: Int}-             |  Var {vnm :: String}-             |  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------ syn att d f     = syndef att (def d f)--- inh att nts d f = inhdef att nts (def d f)-syn = syndefM-inh = inhdefM--$(deriveAG ''AGItf)--exprNT = nt_T_Expr .*. hNil-allNT  = nt_AGItf .*. exprNT- ---$(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)-sppMul    = syn spp $ do  e1 <- at ch_me1 -                          e2 <- at ch_me2-                          return $ e1 # spp >|< " * " >|< e2 # spp -sppAdd    = syn spp $ do  e1 <- at ch_ae1 -                          e2 <- at ch_ae2-                          return $ e1 # spp >|< " + " >|< e2 # spp --sppLet    = syn spp $ do  lnm  <- at ch_lnm-                          val  <- at ch_val-                          body <- at ch_body-                          return $ "let " >|< pp lnm >|< " = " >|< val # spp >|< " in " >|< body # spp    ---$(attLabels ["ienv","sval"])---ienvRule  = copy ienv exprNT  -ienvAGItf = inh ienv exprNT $ do return  (ch_expr .=. ([] :: [(String,Int)]) .*.  emptyRecord)-ienvCst   = ienvRule-ienvVar   = ienvRule-ienvMul   = ienvRule-ienvAdd   = ienvRule-ienvLet   = inh ienv exprNT $ do lnm <- at ch_lnm-                                 val <- at ch_val-                                 lhs <- at lhs-                                 return  $  ch_val   .=.  lhs # ienv .*.-                                            ch_body  .=.  (lnm, val # sval) : lhs # ienv .*.  -                                            emptyRecord---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 -                           lhs <- at lhs-                           return $ fromJust (lookup vnm (lhs # ienv)) -svalMul   = svalRule ((*)::Int->Int->Int)-svalAdd   = svalRule ((+)::Int->Int->Int)-svalLet   = syn sval $ liftM (# sval) (at ch_body)---aspAGItf = sppAGItf `ext` ienvAGItf `ext` svalAGItf-aspCst   = sppCst   `ext` ienvCst   `ext` svalCst  -aspVar   = sppVar   `ext` ienvVar   `ext` svalVar  -aspMul   = sppMul   `ext` ienvMul   `ext` svalMul  -aspAdd   = sppAdd   `ext` ienvAdd   `ext` svalAdd  -aspLet   = sppLet   `ext` ienvLet   `ext` svalLet--{--semAGItf  e  = knit aspAGItf (ch_expr .=. e .*. emptyRecord)--semCst e     = knit aspCst  (ch_cv .=. (\(Record HNil) -> e) .*. emptyRecord)--semVar e     = knit aspVar  (ch_vnm .=. (\(Record HNil) -> e) .*. emptyRecord)--semMul e1 e2 = knit aspMul  (ch_me1 .=. e1 .*. ch_me2 .=. e2 .*. emptyRecord)--semAdd e1 e2 = knit aspAdd  (ch_ae1 .=. e1 .*. ch_ae2 .=. e2 .*. emptyRecord)--semLet l e1 e2 = knit aspLet  (ch_lnm .=. (\(Record HNil) -> l) .*. ch_val .=. e1 .*. ch_body .=. e2 .*. emptyRecord)--}--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  ---- modifications--- syn att d f     = syndef att (def d f)--- inh att nts d f = inhdef att nts (def d f)--- synmod att v (Fam ic sp) = Fam ic (sp .@. att .=. v)--- synM att v f = synmod att (def v f)-synM = synmodM-inhM = inhmodM--$(chLabel "se" ''T_Expr)--sppSq = synM spp $ do me1 <- at ch_me1 -                      return $ "square " >|< (me1 # spp)   --semSq r = knit (sppSq `ext` aspMul)  -               (ch_me1 .=. (r # ch_se) .*. ch_me2 .=. (r # ch_se) .*. emptyRecord)--{--sppSq = synM spp $ do me1 <- at ch_me1 -                      return $ "square " >|< (me1 # spp)   --semSq r = knit (sppSq `ext` aspMul)  (ch_me2 .=. (r # ch_me1) .*. r)--}--$(chLabels ["pe1","pe2"] ''T_Expr)--sppPyth  = synM spp  $ do  ae1 <- at ch_ae1-                           ae2 <- at ch_ae2 -                           return $ "pyth " >|< (ae1 # spp) >|< " "-                                            >|< (ae2 # spp)   -svalPyth = synM sval $ do  ae1 <- at ch_ae1-                           ae2 <- at ch_ae2-                           return  $ (\p1 p2 -> p1 * p1 + p2 * p2 )(ae1 # sval) (ae2 # sval)     -semPyth r = knit (sppPyth `ext` svalPyth `ext` aspAdd) -                 (ch_ae1 .=. (r # ch_pe1) .*. ch_ae2 .=. (r # ch_pe2) .*. emptyRecord)------- identity stuff-$(chLabel "pe" ''T_Expr)-{--synId att     = syn att $ liftM (# att) (at ch_id)-inhId att nts = inh att nts $ do lhs <- at lhs-                                 return  $  ch_id   .=.  (lhs # att) .*. emptyRecord--attsId    = (synId spp) `ext`(inhId ienv exprNT) `ext`(synId sval)--}--sppPar  = syn spp  $ do  pe <- at ch_pe-                         return $ "(" >|< pe # spp >|< ")" -svalPar = syn sval $ do  liftM (# sval) (at ch_pe)-ienvPar = copy ienv exprNT--   -semPar = knit (sppPar `ext` ienvPar `ext` svalPar)---sppSubst = synM spp $ do  lnm   <- at ch_lnm-                          val   <- at ch_val-                          body  <- at ch_body-                          return $ (body # spp) >|< "[" >|< (pp lnm)  >|< " | " >|< (val # spp) >|< "]" -{--ienvSubst = inhM ienv exprNT $ do lnm <- at ch_lnm-                                  val <- at ch_val-                                  lhs <- at lhs-                                  return  $  ch_val   .=.  (lhs # ienv) .*.-                                             ch_body  .=.  ((lnm, val # sval) : (lhs # ienv)) .*.  -                                             emptyRecord--}-semSubst r = knit (sppSubst `ext` {-ienvSubst `ext`-} aspLet) r---

@@ -0,0 +1,48 @@+{-# LANGUAGE  Arrows, DoRec, EmptyDataDecls, FlexibleContexts #-}++module LangDef where++import qualified Data.Set as Set++import Control.Arrow++import UU.Pretty++import Language.Grammars.SyntaxMacros+import Language.Grammars.Grammar++import Language.Grammars.SyntaxMacros.Scanner++import LangSem+import Utils+++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 ]++              factor  <- addNT -<  [  prd semCst $ ch_cv<=>int  <.> prdEnd +                                   ,  prd semVar $ ch_vnm<=>var <.> prdEnd ]++         exportNTs -< Export root $   ntExp     ^=  exp     ^| +                                      ntTerm    ^=  term    ^|+                                      ntFactor  ^=  factor  ^|  +                                      ntNil ++++gramOpts :: ScanOpts+gramOpts+  =  defaultScanOpts+        {   scoKeywordsTxt      =   Set.fromList ["let", "in"]+        ,   scoSpecChars        =   Set.fromList "=+*"+        ,   scoDollarIdent      =   True+        }+

@@ -0,0 +1,103 @@+{-# LANGUAGE  Arrows, DoRec, EmptyDataDecls, FlexibleContexts, TemplateHaskell, NoMonomorphismRestriction #-}++module LangExt where+++import Control.Arrow++import UU.Pretty++import Language.Grammars.AspectAG+import Language.Grammars.AspectAG.Derive++import Language.Grammars.SyntaxMacros+import Language.Grammars.Grammar+++import LangSem+import Utils++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)   ++semSq r = knit (sppSq `ext` aspMul)  +               (ch_me1 .=. (r # ch_se) .*. ch_me2 .=. (r # ch_se) .*. emptyRecord)+++$(chLabels ["pe1","pe2"] ''T_Expr)++sppPyth  = synM spp  $ do  ae1 <- at ch_ae1+                           ae2 <- at ch_ae2 +                           return $ "pyth " >|< (ae1 # spp) >|< " "+                                            >|< (ae2 # spp)   ++svalPyth = synM sval $ do  ae1 <- at ch_ae1+                           ae2 <- at ch_ae2+                           return  $ (\p1 p2 -> p1 * p1 + p2 * p2 )(ae1 # sval) (ae2 # sval)     ++semPyth r = knit (sppPyth `ext` svalPyth `ext` aspAdd) +                 (ch_ae1 .=. (r # ch_pe1) .*. ch_ae2 .=. (r # ch_pe2) .*. emptyRecord)+++++$(chLabel "pe" ''T_Expr)++sppPar  = syn spp  $ do  pe <- at ch_pe+                         return $ "(" >|< pe # spp >|< ")" +svalPar = syn sval $ do  liftM (# sval) (at ch_pe)+ienvPar = copy ienv exprNT++   +semPar = knit (sppPar `ext` ienvPar `ext` svalPar)+++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++++--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))+++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    ])+ ++         let factor  = getNT ntFactor  nts+         addProds   -<  (factor,  [  prd semPar $ trm "(" <.> ch_pe<=>exp <.> trm ")" <.>  prdEnd  ])+         +         exportNTs  -< (Export root nts)++gramOpts' gramOpts = gramOpts `extKeywordsTxt` [ "square", "pyth" ] `extSpecChars` "()[|]"++++

@@ -0,0 +1,101 @@+{-# LANGUAGE TemplateHaskell, EmptyDataDecls, NoMonomorphismRestriction #-}++module LangSem where++import Language.Grammars.AspectAG+import Language.Grammars.AspectAG.Derive++import Data.HList.Label4+import Data.HList.TypeEqGeneric1+import Data.HList.TypeCastGeneric1++import Data.Maybe++import UU.Pretty++import Control.Monad ++data AGItf = AGItf { expr :: T_Expr}+          deriving Show++data T_Expr  =  Cst {cv  :: Int}+             |  Var {vnm :: String}+             |  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++++syn = syndefM+inh = inhdefM++$(deriveAG ''AGItf)++exprNT = nt_T_Expr .*. hNil+allNT  = nt_AGItf .*. exprNT+ +++$(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)+sppMul    = syn spp $ do  e1 <- at ch_me1 +                          e2 <- at ch_me2+                          return $ e1 # spp >|< " * " >|< e2 # spp +sppAdd    = syn spp $ do  e1 <- at ch_ae1 +                          e2 <- at ch_ae2+                          return $ e1 # spp >|< " + " >|< e2 # spp ++sppLet    = syn spp $ do  lnm  <- at ch_lnm+                          val  <- at ch_val+                          body <- at ch_body+                          return $ "let " >|< pp lnm >|< " = " >|< val # spp >|< " in " >|< body # spp    +++$(attLabels ["ienv","sval"])+++ienvRule  = copy ienv exprNT  +ienvAGItf = inh ienv exprNT $ do return  (ch_expr .=. ([] :: [(String,Int)]) .*.  emptyRecord)+ienvCst   = ienvRule+ienvVar   = ienvRule+ienvMul   = ienvRule+ienvAdd   = ienvRule+ienvLet   = inh ienv exprNT $ do lnm <- at ch_lnm+                                 val <- at ch_val+                                 lhs <- at lhs+                                 return  $  ch_val   .=.  lhs # ienv .*.+                                            ch_body  .=.  (lnm, val # sval) : lhs # ienv .*.  +                                            emptyRecord+++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 +                           lhs <- at lhs+                           return $ fromJust (lookup vnm (lhs # ienv)) +svalMul   = svalRule ((*)::Int->Int->Int)+svalAdd   = svalRule ((+)::Int->Int->Int)+svalLet   = syn sval $ liftM (# sval) (at ch_body)+++aspAGItf = sppAGItf `ext` ienvAGItf `ext` svalAGItf+aspCst   = sppCst   `ext` ienvCst   `ext` svalCst  +aspVar   = sppVar   `ext` ienvVar   `ext` svalVar  +aspMul   = sppMul   `ext` ienvMul   `ext` svalMul  +aspAdd   = sppAdd   `ext` ienvAdd   `ext` svalAdd  +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  ++

@@ -1,69 +1,20 @@-{-# LANGUAGE  Arrows, DoRec, EmptyDataDecls, FlexibleContexts #-}-- import qualified Data.Set as Set  import Control.Arrow  import UU.Pretty -import Expr-import Language.Grammars.AspectAG-import qualified Language.Grammars.AspectAG as AG+import LangDef+import LangSem+import LangExt -import Language.Grammars.SyntaxMacros-import Language.Grammars.Grammar +import Language.Grammars.SyntaxMacros import Language.Grammars.SyntaxMacros.Scanner --gramOpts :: ScanOpts-gramOpts-  =  defaultScanOpts-        {   scoKeywordsTxt      =   Set.fromList ["let", "in"]-        ,   scoSpecChars        =   Set.fromList "=+*"-        ,   scoDollarIdent      =   True-        }---extKeywordsTxt ::  ScanOpts -> [String] -> ScanOpts-extKeywordsTxt opts kws = opts { scoKeywordsTxt = scoKeywordsTxt opts  `Set.union` Set.fromList kws }--extSpecChars ::  ScanOpts -> [Char] -> ScanOpts-extSpecChars opts kws = opts { scoSpecChars = scoSpecChars opts  `Set.union` Set.fromList kws }--data NTRoot-ntRoot = undefined :: NTRoot---data NTExp-ntExp = undefined :: NTExp--data NTTerm-ntTerm = undefined :: NTTerm--data NTFactor-ntFactor = undefined :: NTFactor+import Language.Grammars.AspectAG  -prds = proc () -> do-         rec  root    <- addNT -<  [  prd $ (ch_expr,exp)  <#> \e -> semAGItf e () ] --              exp     <- addNT -<  [  prd $ "let" .> (ch_lnm,var) -.>  "=" .> (ch_val,exp) <.> "in" .> (ch_body,exp)   <#>  semLet-                                   ,  prd $ (ch_ae1,term) <.> "+"  .> (ch_ae2,exp)                                     <#>  semAdd-                                   ,  prdId term  ]-                                 -              term    <- addNT -<  [  prd $ (ch_me1,term) <.> "*"  .> (ch_me2,factor)                                  <#>  semMul -                                   ,  prdId factor ]--              factor  <- addNT -<  [  prd $ (ch_cv,int)                                                                -#>  semCst-                                   ,  prd $ (ch_vnm,var)                                                               -#>  semVar ]--         exportNTs -< Export root $   ntExp     ^=  exp     ^| -                                      ntTerm    ^=  term    ^|-                                      ntFactor  ^=  factor  ^|  -                                      ntNil - gram = closeGram prds  test1 = do@@ -73,31 +24,11 @@         print $ res # sval  -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)) ---extended grammar (syntax macro) -prds'  ::    ( NTRecord (nts env) -             , GetNT NTExp    (nts env)  (Symbol AttExpr env)-             , GetNT NTFactor (nts env)  (Symbol AttExpr env)) -       =>    SyntaxMacro env (Export start nts) (Export start nts)-prds' = proc (Export root nts) -> do-         let exp     = getNT ntExp     nts-         addProds   -<  (exp,     [  prd $ "square"  .> (ch_se,exp)                                                <#>  semSq -                                  ,  prd $ "pyth"    .> (ch_pe1,exp) <.> (ch_pe2,exp)                              <#>  semPyth-                                  ,  prd $ (ch_body,exp) <.> "[" .> (ch_lnm,var) -.> "|" .> (ch_val,exp) <.> "]"   #>   semSubst ])- --         let factor  = getNT ntFactor  nts-         addProds   -<  (factor,  [  prd $ "(" .> (ch_pe,exp) <.> ")"                                              #>   semPar ])-         -         exportNTs  -< (Export root nts)- gram' = closeGram (extendGram prds prds')   test2 = do-        tokens <- scanFile (gramOpts `extKeywordsTxt` [ "square", "pyth" ] `extSpecChars` "()[|]") "prog2.src"+        tokens <- scanFile (gramOpts' gramOpts) "prog2.src"         case ( parse . compile ) gram' tokens of            (Ok res) -> do print $ res # spp                           print $ res # sval

@@ -0,0 +1,9 @@+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

@@ -0,0 +1,33 @@+{-# LANGUAGE  EmptyDataDecls #-}++module Utils where++import qualified Data.Set as Set++import UU.Pretty++import Language.Grammars.SyntaxMacros+import Language.Grammars.Grammar++import Language.Grammars.SyntaxMacros.Scanner++extKeywordsTxt ::  ScanOpts -> [String] -> ScanOpts+extKeywordsTxt opts kws = opts { scoKeywordsTxt = scoKeywordsTxt opts  `Set.union` Set.fromList kws }++extSpecChars ::  ScanOpts -> [Char] -> ScanOpts+extSpecChars opts kws = opts { scoSpecChars = scoSpecChars opts  `Set.union` Set.fromList kws }++data NTRoot+ntRoot = undefined :: NTRoot++data NTExp+ntExp = undefined :: NTExp++data NTTerm+ntTerm = undefined :: NTTerm++data NTFactor+ntFactor = undefined :: NTFactor++trm = Term+

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

@@ -0,0 +1,11 @@+{-# 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

@@ -1,4 +1,5 @@-{-# LANGUAGE ExistentialQuantification, GADTs #-}+{-# LANGUAGE ExistentialQuantification, GADTs, EmptyDataDecls, +    MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, FlexibleContexts, UndecidableInstances  #-}  module Language.Grammars.Grammar where @@ -14,34 +15,39 @@   = PS {unPS :: [Prod a env]}  data Prod a env where-      Seq   ::  Symbol    b        env  ->  Prod   (b -> a)  env  +      Seq   ::  Symbol    b  t     env  ->  Prod   (b -> a)  env                                           ->  Prod   a         env       End   ::  a                       ->  Prod   a         env  data DTerm = DTerm -data Symbol a env where-  Term    :: String    ->  Symbol  DTerm      env+data TTerm+data TNonT+data TAttT -  Nont    :: Ref a env ->  Symbol  a          env+data Symbol a t env where+  Term    :: String    ->  Symbol  DTerm    TTerm   env++  Nont    :: Ref a env ->  Symbol  a        TNonT   env   -- attributed terminals-  NontInt   ::             Symbol  Int        env-  NontChar  ::             Symbol  Char       env-  NontVarid ::             Symbol  String     env-  NontConid ::             Symbol  String     env-  NontOp    ::             Symbol  String     env +  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    --- TODO: the rest of EnumValToken -infixl 5  `ext`-ext :: Env Productions env def' -> [Prod a env]-    -> Env Productions env (def', a)-ext g = Ext g . PS +getRefNT :: Symbol a TNonT env -> Ref a env+getRefNT (Nont ref) = ref  +pairEq :: Maybe (Equal a b) -> Maybe (Equal (a,t) (b,t))+pairEq (Just Eq) = Just Eq+pairEq Nothing   = Nothing -matchSym  ::  Symbol a env -> Symbol b env -          ->  Maybe (Equal a b)-matchSym (Nont x)   (Nont y)             = match x y+matchSym  ::  Symbol a t1 env -> Symbol b t2 env +          ->  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@@ -50,86 +56,75 @@ matchSym _          _                    = Nothing  -append  :: (a -> b -> c) -> Prod a env -> Symbol b env +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)  -data Lit a env = Lit (a env)+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   ::  Lit (Symbol Int) env-char  ::  Lit (Symbol Char) env-var   ::  Lit (Symbol String) env-con   ::  Lit (Symbol String) env-op    ::  Lit (Symbol String) env+int   =  NontInt+char  =  NontChar+var   =  NontVarid+con   =  NontConid+op    =  NontOp -int   =  Lit NontInt-char  =  Lit NontChar-var   =  Lit NontVarid-con   =  Lit NontConid-op    =  Lit NontOp -infixr 6 -:--(-:-) = (,)+data EP a b env = EP a (b env)+infixr 6 <=> -infixr 5 <.>, -.>, .>, <#>, -#>, #>+(<=>) ::  a -> b env -> EP a b env+(<=>) = EP -prd a = a ($)-prdId nt = Seq nt  $ End id -((chn,s)   <.>  ps)  f =  Seq s $ ps f'-        where f' sem r = \x -> f sem (chn .=. x .*. r) --(pn,Lit s) -.> pp = \r ->  Seq s $ pp (f r)-               where f r ff p = \x -> r ff (pn .=. (\(Record HNil) -> x) .*. p) --s  .> pp = \r ->  Seq (Term s) $ pp (f r)-               where f r ff p = \DTerm -> r ff p -+infixr 5 <.> -((chn,s)   <#>  sem) f = Seq s (End $ f')-        where f' = \x -> f  sem -                             (chn .=. x .*. emptyRecord)+data PreProd a b env = PreProd (a -> (Prod b env)) -(pn,Lit s) -#> ff = \r -> Seq s (End $ f r)-               where f r = \x -> r ff (pn .=. (\(Record HNil) -> x) .*. emptyRecord)+class ProdSeq a b c d | a c -> b d  where+  (<.>) :: a env -> b env -> PreProd c d env -s  #> ff = \r ->  Seq (Term s) (End $ f r)-               where f r = \DTerm -> r ff emptyRecord +instance (HExtend (LVPair t v) l l') => ProdSeq  +        (EP t (Symbol b TNonT))+        (PreProd (l -> v -> t2) (b -> a))+        (l' -> t2)+        a where -{---- DOESN'T WORK+  (EP chn s)   <.>  (PreProd ps) = PreProd $ +         \f ->  let f' r = \x -> f (chn .=. x .*. r) +                in   Seq s $ ps f' -class ProdSeq a b c v v' | a -> b, b -> c  where-  (<.>) ::  (HExtend (LVPair t v) l l') =>-             (t, a env)-> -             ((t1 -> l -> v' -> t2) -> Prod b env)-> -             (t1 -> l' -> t2)-> -             Prod c env+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 -instance ProdSeq (Symbol b) (b->a) a v v where-  (pn,s) <.> pp = \r ->  Seq s $ pp (f r)-               where f r ff p = \x -> r ff (pn .=. x .*. p) +   (EP pn s) <.> (PreProd pp) =  PreProd $ \r ->  Seq s $ pp (f r)+               where f r p = \x -> r (pn .=. (\(Record HNil) -> x) .*. p)   -instance ProdSeq (Lit (Symbol b)) (b->a) a (Record HNil -> v) v  where-  (pn,Lit s) <..> pp = \r ->  Seq s $ pp (f r)-               where f r ff p = \x -> r ff (pn .=. (\(Record HNil) -> x) .*. p) ---- WORKS+instance ProdSeq+        (Symbol DTerm TTerm)+        (PreProd (t1 -> DTerm -> t2) (DTerm -> a))+        (t1 -> t2)+        a where -class ProdEnd a b | a -> b where-  (<#>) :: (t, a env) -> t1-> (t1 -> Record (HCons (LVPair t b) HNil) -> t2) -> Prod t2 env+  s  <.> (PreProd pp) = PreProd $ \r -> Seq s $ pp (f r)+               where f r p = \DTerm -> r p  -instance ProdEnd (Symbol v) v where-  (pn,s) <#> ff = \r -> Seq s (End $ f r)-               where f r = \x -> r ff (pn .=. x .*. emptyRecord)+prdEnd ::  PreProd (Record HNil -> b) b env+prdEnd = PreProd $ \f -> End (f emptyRecord) -instance ProdEnd (Lit (Symbol v)) (Record HNil -> v) where- (pn,Lit s) <#> ff = \r -> Seq s (End $ f r)-               where f r = \x -> r ff (pn .=. (\(Record HNil) -> x) .*. emptyRecord)--}+prd ::  (a -> b) -> PreProd (a -> b) t t1 -> Prod t t1+prd sem (PreProd ps) = ps sem   +prdId ::  Symbol a TNonT env -> Prod a env+prdId nt = Seq nt  $ End id 

@@ -7,7 +7,7 @@ import Language.AbstractSyntax.TTTAS import Control.Arrow -import UU.Parsing hiding (Symbol,parse,Ok)+import UU.Parsing.Interface hiding (Symbol,parse,Ok) import qualified UU.Parsing as UU import Language.Grammars.SyntaxMacros.Scanner @@ -21,10 +21,10 @@ type SyntaxMacro  env nts  nts'              = GramTrafo env  (nts env)  (nts' env) -data Export start nts env = Export (Symbol start env) (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 env)+addNT  ::  GramTrafo env [Prod a env] (Symbol a TNonT env) addNT  =  proc  p -> do                  r  <- newSRef -< PS p                 returnA -< Nont r@@ -32,11 +32,12 @@  -- add productions to an existing non-terminal addProds  ::  GramTrafo  env -                          (Symbol a env, [Prod a env]) ()-addProds  = proc (Nont nt, prds) -> do+                         (Symbol a TNonT env, [Prod a env]) ()+addProds  = proc (nt, prds) -> do       updateFinalEnv  -< -         updateEnv (\(PS ps) -> PS $ prds ++ ps) nt+         updateEnv (\(PS ps) -> PS $ prds ++ ps) (getRefNT nt) +  -- close the grammar closeGram :: (forall env. ExtGram  env (Export a nts))                  -> Grammar a @@ -57,7 +58,7 @@  -- extensible record -newtype  NTField nt a env = NTField { symbolNTField :: (Symbol a env) }  +newtype  NTField nt a env = NTField { symbolNTField :: (Symbol a TNonT env) }    labelNTField :: NTField nt a env -> nt labelNTField _ = undefined@@ -79,11 +80,11 @@ instance Fail (Duplicated nt)      => NotDuplicated nt  (NTCons nt v l env) -- using overlapping instance NotDuplicated nt1 (l env) => NotDuplicated nt1 (NTCons nt2 v l env) -+ntNil :: NTNil env ntNil = NTNil  infixr 4 ^= -(^=) :: nt -> (Symbol a env) -> NTField nt a env+(^=) :: nt -> (Symbol a TNonT env) -> NTField nt a env (^=) _ = NTField  @@ -99,7 +100,7 @@  instance Fail (NotFound nt) => GetNT nt (NTNil env) r where  getNT = undefined-instance GetNT nt  (NTCons nt v l env) (Symbol v env) where -- using overlapping+instance GetNT nt  (NTCons nt v l env) (Symbol v TNonT env) where -- using overlapping  getNT _ (NTCons f _)  = symbolNTField f instance GetNT nt1 (l env) r => GetNT nt1 (NTCons nt2 v l env) r where  getNT nt (NTCons _ l)  = getNT nt l@@ -119,6 +120,8 @@ pVar            =    id <$> pVarid pOp             =    id <$> pVarsym +pTerm           ::  (UU.Parsing.Interface.IsParser p Token) +                =>  String -> p DTerm pTerm t         =  const DTerm <$>   (pKey t)  newtype Const f a s = C {unC :: f a}

@@ -6,12 +6,12 @@ import Language.Grammars.Grammar  newtype MapA_X env a env'-  = MapA_X (forall x. Symbol x env -> Maybe (Ref (x -> a) env'))+  = MapA_X (forall x t. Symbol x t env -> Maybe (Ref (x -> a) env'))  emptyMap :: MapA_X env a env' emptyMap  = MapA_X (const Nothing) -extendMap :: Symbol x env -> MapA_X env a env'+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@@ -30,8 +30,8 @@                             TrafoE _ f -> TrafoE Unit f                 ) -newNontR ::  forall x env s a -         .   Symbol x env +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) 

@@ -54,7 +54,7 @@                         rule2  :: Env Productions env env -       -> Symbol x env +       -> Symbol x t env         -> GramTrafo env a s (T env s, Ref (x -> a) s)                              (Productions a s) rule2 _    (Term a) @@ -83,7 +83,7 @@         do  returnA -< PS [rule2a' NontOp a_x]  -rule2a' :: Symbol a s-> Ref (a -> b) s -> Prod b s+rule2a' :: Symbol a t s -> Ref (a -> b) s -> Prod b s rule2a' s refA_a      =  Seq s $ Seq (Nont refA_a) $ End ($)  @@ -102,9 +102,9 @@                                               (mapProd tenv_s beta)                                                (Nont a_b)) -insert ::  forall env s a x+insert ::  forall x t env s a        .   Env Productions env env -       ->  Symbol x env+       ->  Symbol x t env        ->  GramTrafo env a s  (T env s, Prod (x->a) s)                               (Productions a s) insert gram x = 

@@ -11,7 +11,7 @@   --list of repeated symbols (with hidden type)-data AnySym env = forall x. AnySym (Symbol x env)+data AnySym env = forall x t. AnySym (Symbol x t env)  newtype BT env s = BT (Bool, T env s) @@ -93,7 +93,7 @@ -- added, so we obtain the reference of the nonterminal and add the new -- production. -- Otherwise, we have to create the new nonterminal (newNontR x).-rinsert :: forall env s a x. Symbol x env+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 (@@ -115,7 +115,7 @@            )  -addprod :: Symbol x env -> GramTrafo env a s (T env s, Ref (x -> a) s) +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 ($)]@@ -150,7 +150,7 @@ aux (Just Eq) = False aux Nothing   = True   -iselem :: Symbol t env -> [AnySym env] -> Bool+iselem :: Symbol a t env -> [AnySym env] -> Bool iselem _ []              = False iselem x ((AnySym y):ys) = case (matchSym x y) of                                   (Just Eq) -> True