qmrparser-vignette.R
In qmrparser: Parser Combinator in R

### R code from vignette source 'qmrparser-vignette.Rnw'
### Encoding: UTF-8

###################################################
### code chunk number 1: vignette
###################################################
list_expression  <- function() 
concatenation(
concatenation(additive_expression(),ws(),keyword(';'),
action=function(s) print(exprToString(s[[1]]))),
repetition0N(
concatenation(additive_expression(),ws(),keyword(';'),
action=function(s) print(exprToString(s[[1]])))),
action=function(s) NULL)


###################################################
### code chunk number 2: vignette
###################################################
library(qmrparser)

additive_expression  <- function()  concatenation(ws(),multiplicative_expression(),
option( concatenation(ws(),
alternation(
keyword('+',action=function(s) s),
keyword('-',action=function(s) s),
action=function(s) s),
ws(),additive_expression(),
action=function(s) list(type='noempty',value=s[c(2,4)]))),
action=function(s) {if(s[[3]]$value$type=='empty') s[[2]] else
list(fun=s[[3]]$value$value[[1]],par1=s[[2]],par2=s[[3]]$value$value[[2]])
});


###################################################
### code chunk number 3: vignette
###################################################
multiplicative_expression  <- function()  
concatenation(power_expression(),
option(
concatenation(ws(),
alternation(
keyword('*',action=function(s) s),
keyword('/',action=function(s) s),
action=function(s) s),
ws(),multiplicative_expression(),
action=function(s) {list(type='noempty',value=s[c(2,4)])})),
action=function(s) {
if(s[[2]]$value$type=='empty') s[[1]] else
list(fun=s[[2]]$value$value[[1]],par1=s[[1]],par2=s[[2]]$value$value[[2]])});


###################################################
### code chunk number 4: vignette
###################################################
power_expression  <- function()  
concatenation(primary(),
option(
concatenation(ws(),keyword('**'),ws(),power_expression(),
action=function(s) list(type='noempty',value=s[[4]]))),
action=function(s){if(s[[2]]$value$type=='empty') s[[1]] else list(fun="^",par1=s[[1]],par2=s[[2]]$value$value)});


###################################################
### code chunk number 5: vignette
###################################################
primary  <- function()  alternation(
concatenation(charParser('('),ws(),additive_expression(),ws(),charParser(')'),action=function(s)  s[[3]]),

concatenation(charParser('-'),ws(),primary(),
action=function(s) list(fun="U-",par1=s[[3]])),

concatenation(FUN(action=function(s) s), ws(), charParser('('), ws(), additive_expression(), ws(), charParser(')'),
action=function(s) list(fun=s[[1]],par1=s[[5]])),

NUMBER  (action=function(s) list(fun="NUM", par1=s)),

VARIABLE(action=function(s) list(fun="VAR", par1=s)),
action=function(s) s);


###################################################
### code chunk number 6: vignette
###################################################
NUMBER    <- function(...)  numberScientific(...);

VARIABLE  <- function(...)  symbolic(...);

FUN       <- function(...)  symbolic(...);

ws        <- function()     whitespace();


###################################################
### code chunk number 7: vignette
###################################################
exprToString <- function(expr) 
if ( !is.list(expr) ) as.character(expr) else
paste("(",paste(sapply(expr,exprToString,USE.NAMES=FALSE),collapse=" "),")")


###################################################
### code chunk number 8: vignette
###################################################
print("Infix to Prefix Examples")
 
invisible( list_expression()(streamParserFromString(" 8  ;")) )

invisible( list_expression()(streamParserFromString("8 +4;")) )

invisible( list_expression()(streamParserFromString("8/2 ;")) )

invisible( list_expression()(streamParserFromString("8*2 ;")) )

invisible( list_expression()(streamParserFromString("2*3 + 4*5;")) )

invisible( list_expression()(streamParserFromString("sqrt( 16) ;")) )

invisible( list_expression()(streamParserFromString("sin(3.1415) ;")) )

invisible( list_expression()(streamParserFromString("sin(3.14* (2*2+3+1)/2 ) ** 8;")) )

invisible( list_expression()(streamParserFromString("sqrt(16)**2+sin(3)-sin(3);")) )

invisible( list_expression()(streamParserFromString("sqrt(16)**2+sin(3)-sin(3)*2;") ) )
           


###################################################
### code chunk number 9: vignette
###################################################
exprToNumber <- function(expr)  
switch(expr[[1]],
'NUM'= as.numeric(expr[[2]]),
'VAR' =as.numeric(get(expr[[2]])),
'U-'=-exprToNumber(expr[[2]]),
do.call(expr[[1]],unname(lapply(expr[-1],exprToNumber)))
)	 


###################################################
### code chunk number 10: vignette
###################################################
list_expression  <- function() 
concatenation(
concatenation(additive_expression(),ws(),keyword(';'),
action=function(s) print(exprToString(exprToNumber(s[[1]])))),
repetition0N(
concatenation(additive_expression(),ws(),keyword(';'),
action=function(s) print(exprToString(exprToNumber(s[[1]]))))),
action=function(s) NULL);


###################################################
### code chunk number 11: vignette
###################################################
print("Calculator")

invisible( list_expression()(streamParserFromString(" 8  ;")) )
          
invisible( list_expression()(streamParserFromString("8 +4;")) )

invisible( list_expression()(streamParserFromString("8/2 ;")) )
          
invisible( list_expression()(streamParserFromString("8*2 ;")) )
          
invisible( list_expression()(streamParserFromString("2*3 + 4*5;")) )

invisible( list_expression()(streamParserFromString("sqrt( 16) ;")) )

invisible( list_expression()(streamParserFromString("sin(3.1415) ;")) )

invisible( list_expression()(streamParserFromString("sin(3.14* (2*2+3+1)/2 ) ** 8;")) )

invisible( list_expression()(streamParserFromString("sqrt(16)**2+sin(3)-sin(3);")) )

invisible( list_expression()(streamParserFromString("sqrt(16)**2+sin(3)-sin(3)*2;")) )



###################################################
### code chunk number 12: vignette
###################################################
exprDeriv <- function(expr,var)  
switch(expr[[1]],
'NUM'= list("NUM", "0"),
'VAR'  = if( expr[[2]] == var ) list("NUM" ,"1") else list("NUM", "0"),
"+"=,"-"= list(expr[[1]],exprDeriv(expr[[2]],var),exprDeriv(expr[[3]],var)),
"*"    =list("+",
              list("*",expr[[2]],exprDeriv(expr[[3]],var)),
              list("*",expr[[3]],exprDeriv(expr[[2]],var))
	 ),
"/"    =list("*",
             list("-",
              list("*",expr[[3]],exprDeriv(expr[[2]],var)),
              list("*",expr[[2]],exprDeriv(expr[[3]],var))
	      
	     ),	 
	     list("**",expr[[3]],"2")
	 ),
"sin"=list("*",exprDeriv(expr[[2]],var),list("cos", expr[[2]])),
	 list(paste("Diff",var,sep="_"),expr)
)	 


###################################################
### code chunk number 13: vignette
###################################################
list_expression  <- function() 
concatenation(
concatenation(additive_expression(),ws(),keyword(';'),
action=function(s) print(exprToString(exprDeriv(s[[1]],"x")))),
repetition0N(
concatenation(additive_expression(),ws(),keyword(';'),
action=function(s) print(exprToString(exprDeriv(s[[1]],"x"))))),
action=function(s) NULL);


###################################################
### code chunk number 14: vignette
###################################################
print("Differentiation")

invisible( list_expression()(streamParserFromString(" 8  ;")) )

invisible( list_expression()(streamParserFromString(" x  ;")) )
          
invisible( list_expression()(streamParserFromString("8 +x;")) )
          
invisible( list_expression()(streamParserFromString("x/2 ;")) )

invisible( list_expression()(streamParserFromString("8*x ;")) )

invisible( list_expression()(streamParserFromString("2*x + 4*x;")) )

invisible( list_expression()(streamParserFromString("1+sqrt( x) ;")) )

invisible( list_expression()(streamParserFromString("sin(x) ;")) )

invisible( list_expression()(streamParserFromString("sin(x* (2*2+x+1)/2 ) ** 8;")) )



###################################################
### code chunk number 15: vignette
###################################################
gramatica <- function() 
concatenation( 
repetition1N(
concatenation(ebnfRule(),whitespace(),action=function(s) s[[1]]),
action=function(s) s),
eofMark(error=function(p) errorFun(p,h=NULL,type="eofMark")),
action=function(s) unlist(s[[1]]) ) 


###################################################
### code chunk number 16: vignette
###################################################
ebnfRule <- function()
concatenation(

whitespace(),

symbolic(charFirst=isLetter,charRest=function(ch) isLetter(ch) || isDigit(ch) || ch == "_",action=function(s) s),

whitespace(),charParser("="),

whitespace(),ebnfDefinition(),whitespace(),charParser(';'),whitespace(),

action=function(s) paste(s[[2]]," <- function() ", s[[6]]))


###################################################
### code chunk number 17: ebnfDefinition
###################################################
ebnfDefinition <- function() alternation(
# several alternatives
ebnfAlternation(),
# No alternatives
ebnfNonAlternation(),
action=function(s) s)


###################################################
### code chunk number 18: ebnfAlternation
###################################################
ebnfAlternation <- function() 
concatenation(
ebnfNonAlternation(),

repetition1N(
concatenation(whitespace(),charParser("|"),whitespace(),ebnfNonAlternation(),action=function(s) s[[4]]),action=function(s) s),
action=function(s) paste("alternation(",paste(s[[1]],",",paste(unlist(s[[2]]), collapse=","), sep=""),")",sep=""))


###################################################
### code chunk number 19: vignette
###################################################
ebnfConcatenation <- function()
option(
concatenation(
whitespace(),charParser(","),whitespace(),
ebnfNonAlternation(),
action=function(s) list(type="noempty",value=s[[4]])))


###################################################
### code chunk number 20: ebnfNonAlternation-string (eval = FALSE)
###################################################
## # string
## concatenation(
## string(action=function(s) paste("keyword('",s,"')",sep="")),
## ebnfConcatenation(),
## action=function (s) 
## if(s[[2]]$value$type=="empty") s[[1]]
## else paste("concatenation(",s[[1]],",",s[[2]]$value$value,")",sep=""))


###################################################
### code chunk number 21: ebnfNonAlternation-special (eval = FALSE)
###################################################
## # special sequence
## concatenation(
## ebnfSpecialSequence(),
## ebnfConcatenation(),
## action=function (s) 
## if(s[[2]]$value$type=="empty") s[[1]]
## else paste("concatenation(",s[[1]],",",s[[2]]$value$value,")",sep=""))


###################################################
### code chunk number 22: ebnfNonAlternation-rule (eval = FALSE)
###################################################
## # rule call
## concatenation(
## symbolic(charFirst=isLetter,charRest=function(ch) isLetter(ch) || isDigit(ch) || ch == "_",action=function(s) paste(s,"()",sep="")),
## ebnfConcatenation(),
## action=function (s) 
## if(s[[2]]$value$type=="empty") s[[1]]
## else paste("concatenation(",s[[1]],",",s[[2]]$value$value,")",sep=""))


###################################################
### code chunk number 23: ebnfNonAlternation-grouping (eval = FALSE)
###################################################
## # grouping
## concatenation(
## whitespace(),charParser("("),whitespace(),
## ebnfDefinition(),
## whitespace(),charParser(")"),
## ebnfConcatenation(),
## action=function (s) 
## if(s[[7]]$value$type=="empty") s[[4]]
## else paste("concatenation(",s[[4]],",",s[[7]]$value$value,")",sep=""))


###################################################
### code chunk number 24: ebnfNonAlternation-repetition (eval = FALSE)
###################################################
## # repetition
## concatenation(
## whitespace(),charParser("{"),whitespace(),
## ebnfDefinition(),
## whitespace(),charParser("}"),
## ebnfConcatenation(),
## action=function (s) 
## if(s[[7]]$value$type=="empty") paste("repetition0N(",s[[4]],")")
## else paste("concatenation(",   paste("repetition0N(",s[[4]],")"),",", s[[7]]$value$value,")",sep=""))


###################################################
### code chunk number 25: ebnfNonAlternation-option (eval = FALSE)
###################################################
## # option
## concatenation(
## whitespace(),charParser("["),whitespace(),
## ebnfDefinition(),
## whitespace(),charParser("]"),
## ebnfConcatenation(),
## action=function (s) 
## if(s[[7]]$value$type=="empty") paste("option(",s[[4]],")")
## else paste("concatenation(",   paste("option(",s[[4]],")"),",", s[[7]]$value$value,")",sep=""))


###################################################
### code chunk number 26: vignette
###################################################
ebnfAlternation <- function() 
concatenation(
ebnfNonAlternation(),

repetition1N(
concatenation(whitespace(),charParser("|"),whitespace(),ebnfNonAlternation(),action=function(s) s[[4]]),action=function(s) s),
action=function(s) paste("alternation(",paste(s[[1]],",",paste(unlist(s[[2]]), collapse=","), sep=""),")",sep=""))
 ebnfNonAlternation <- function() alternation(
# string
concatenation(
string(action=function(s) paste("keyword('",s,"')",sep="")),
ebnfConcatenation(),
action=function (s) 
if(s[[2]]$value$type=="empty") s[[1]]
else paste("concatenation(",s[[1]],",",s[[2]]$value$value,")",sep=""))
                                              ,
# special sequence
concatenation(
ebnfSpecialSequence(),
ebnfConcatenation(),
action=function (s) 
if(s[[2]]$value$type=="empty") s[[1]]
else paste("concatenation(",s[[1]],",",s[[2]]$value$value,")",sep=""))
                                              ,
# rule call
concatenation(
symbolic(charFirst=isLetter,charRest=function(ch) isLetter(ch) || isDigit(ch) || ch == "_",action=function(s) paste(s,"()",sep="")),
ebnfConcatenation(),
action=function (s) 
if(s[[2]]$value$type=="empty") s[[1]]
else paste("concatenation(",s[[1]],",",s[[2]]$value$value,")",sep=""))
                                              ,
# grouping
concatenation(
whitespace(),charParser("("),whitespace(),
ebnfDefinition(),
whitespace(),charParser(")"),
ebnfConcatenation(),
action=function (s) 
if(s[[7]]$value$type=="empty") s[[4]]
else paste("concatenation(",s[[4]],",",s[[7]]$value$value,")",sep=""))
                                              ,
# repetition
concatenation(
whitespace(),charParser("{"),whitespace(),
ebnfDefinition(),
whitespace(),charParser("}"),
ebnfConcatenation(),
action=function (s) 
if(s[[7]]$value$type=="empty") paste("repetition0N(",s[[4]],")")
else paste("concatenation(",   paste("repetition0N(",s[[4]],")"),",", s[[7]]$value$value,")",sep=""))
                                              ,
# option
concatenation(
whitespace(),charParser("["),whitespace(),
ebnfDefinition(),
whitespace(),charParser("]"),
ebnfConcatenation(),
action=function (s) 
if(s[[7]]$value$type=="empty") paste("option(",s[[4]],")")
else paste("concatenation(",   paste("option(",s[[4]],")"),",", s[[7]]$value$value,")",sep=""))
                                              , action=function(s) s)
ebnfDefinition <- function() alternation(
# several alternatives
ebnfAlternation(),
# No alternatives
ebnfNonAlternation(),
action=function(s) s)


###################################################
### code chunk number 27: vignette
###################################################
ebnfSpecialSequence <- function()
concatenation(whitespace(),charParser("?"),whitespace(),
alternation(
keyword("whitespace"      ,action=function(s) s), 
keyword("symbolic"        ,action=function(s) s), 
keyword("string"          ,action=function(s) s), 
keyword("numberInteger"   ,action=function(s) s),
keyword("numberScientific",action=function(s) s),
action=function(s) paste(s,"()",sep="")),
whitespace(),charParser("?"),
action=function(s) s[[4]])


###################################################
### code chunk number 28: vignette
###################################################

  errorFun <- function(strmPosition,h=NULL,type="") { 
    if ( is.null(h) || type != "concatenation" )
      print(paste("Error from line:",strmPosition$line,
      " Caracter:",strmPosition$linePos," Stream Pos:", strmPosition$streamPos, "Type:",type))
    else errorFun(h$pos,h$h,h$type)
      
    return(list(type=type,pos=strmPosition,h=h))
  } 


###################################################
### code chunk number 29: vignette
###################################################
stream  <- streamParserFromString('program = \'PROGRAM\' ;')
cstream <- ebnfRule()(stream)
print(cstream[c("status","node")])	   


###################################################
### code chunk number 30: vignette
###################################################
stream <- streamParserFromString('program =  \'PROGRAM\' , white_space , identifier , white_space ;')
cstream <- ebnfRule()(stream)
print(cstream[c("status","node")])	   


###################################################
### code chunk number 31: vignette
###################################################
stream <- streamParserFromString(
'
program = \'PROGRAM\' , white_space , identifier , white_space ,
          \'BEGIN\'   , white_space ,
           { assignment , ";" , white_space } ,
           \'END.\' ;
')
cstream <- ebnfRule()(stream)
print(cstream[c("status","node")])	   


###################################################
### code chunk number 32: vignette
###################################################
stream <- streamParserFromString(
'identifier = alphabetic_character , { alphabetic_character | digit } ;')
cstream <- ebnfRule()(stream)
print(cstream[c("status","node")])	   


###################################################
### code chunk number 33: vignette
###################################################
stream <- streamParserFromString('white_space = ? whitespace ? ;')
cstream <- ebnfRule()(stream)
print(cstream[c("status","node")])	   


###################################################
### code chunk number 34: vignette
###################################################
stream <- streamParserFromString(
'
program = \'PROGRAM\' , white_space , identifier , white_space ,
          \'BEGIN\'   , white_space ,
           { assignment , ";" , white_space } ,
           \'END.\' ;
identifier = alphabetic_character , { alphabetic_character | digit } ;
number = [ "-" ] , digit , { digit } ;
assignment = identifier , ":=" , ( number | identifier | string_ ) ;
alphabetic_character = "A" | "B" | "C" | "D" | "E" | "F" | "G"
                     | "H" | "I" | "J" | "K" | "L" | "M" | "N"
                     | "O" | "P" | "Q" | "R" | "S" | "T" | "U"
                     | "V" | "W" | "X" | "Y" | "Z" ;
digit = "0" | "1" | "2" | "3" | "4" | "5" | "6" | "7" | "8" | "9" ;
white_space = ? whitespace ? ;
string_ = ? string ?;
')

cstream <- gramatica()(stream)
print(cstream[c("status")])


###################################################
### code chunk number 35: vignette
###################################################
print(cstream[[c("node")]])
eval(parse(text=cstream[[c("node")]]))


###################################################
### code chunk number 36: vignette
###################################################
identifier()(streamParserFromString("DEMO1"))$status

identifier()(streamParserFromString("A0"))$status

keyword(':=')(streamParserFromString(":="))$status

number()(streamParserFromString("3"))$status


###################################################
### code chunk number 37: vignette
###################################################
stream <- streamParserFromString(
'PROGRAM DEMO1
BEGIN
  A0:=3;
  B:=45;
  H:=-100023;
  C:=A;
  D123:=B34A;
  BABOON:=GIRAFFE;
  TEXT:="Hello world!";
END.')


cstream <- program()(stream)
if ( cstream$status=="fail" ) errorFun(cstream$node$pos,cstream$node$h,cstream$node$type) else print(cstream[c("status")])