SyntaxMacros-0.1: examples/Main.hs

{-# 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 Language.Grammars.SyntaxMacros
import Language.Grammars.Grammar

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


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
        tokens <- scanFile gramOpts "prog.src"
        let (Ok res) = (parse . compile ) gram tokens
        print $ res # spp
        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"
        case ( parse . compile ) gram' tokens of
           (Ok res) -> do print $ res # spp
                          print $ res # sval
           (Rep _ err) -> print err


main = test1 >> test2