HXQ-0.8: XQueryParser.y
{-------------------------------------------------------------------------------------
-
- An XQuery parser
- Programmer: Leonidas Fegaras
- Email: fegaras@cse.uta.edu
- Web: http://lambda.uta.edu/
- Creation: 02/15/08, last update: 05/01/08
-
- Copyright (c) 2008 by Leonidas Fegaras, the University of Texas at Arlington. All rights reserved.
- This material is provided as is, with absolutely no warranty expressed or implied.
- Any use is at your own risk. Permission is hereby granted to use or copy this program
- for any purpose, provided the above notices are retained on all copies.
-
--------------------------------------------------------------------------------------}
{
module XML.HXQ.Parser where
import Char
}
%name parse
%tokentype { Token }
%error { parseError }
%token
'return' { RETURN }
'some' { SOME }
'every' { EVERY }
'if' { IF }
'then' { THEN }
'else' { ELSE }
'[' { LB }
']' { RB }
'(' { LP }
')' { RP }
'{' { LSB }
'}' { RSB }
'\'{' { LESCAPE }
'}\'' { RESCAPE }
'to' { TO }
'+' { PLUS }
'-' { MINUS }
'*' { TIMES }
'div' { DIV }
'idiv' { IDIV }
'mod' { MOD }
'=' { TEQ }
'!=' { TNE }
'<' { TLT }
'<=' { TLE }
'>' { TGT }
'>=' { TGE }
'<<' { PRE }
'>>' { POST }
'is' { IS }
'eq' { SEQ }
'ne' { SNE }
'lt' { SLT }
'le' { SLE }
'gt' { SGT }
'ge' { SGE }
'and' { AND }
'or' { OR }
'not' { NOT }
'union' { UNION }
'intersect' { INTERSECT }
'except' { EXCEPT }
'for' { FOR }
'let' { LET }
'in' { IN }
',' { COMMA }
':=' { ASSIGN }
'where' { WHERE }
'order' { ORDER }
'by' { BY }
'ascending' { ASCENDING }
'descending' { DESCENDING }
'element' { ELEMENT }
'attribute' { ATTRIBUTE }
'</' { STAG }
'/>' { ETAG }
'satisfies' { SATISFIES }
'@' { ATSIGN }
'/' { SLASH }
'QName' { QName $$ }
'declare' { DECLARE }
'function' { FUNCTION }
'variable' { VARIABLE }
'at' { AT }
'..' { DOTS }
'.' { DOT }
';' { SEMI }
'Variable' { Variable $$ }
'XMLtext' { XMLtext $$ }
'Integer' { TInteger $$ }
'Double' { TFloat $$ }
'String' { TString $$ }
%nonassoc 'for' 'let' 'satisfies' 'return'
%nonassoc 'else'
%left 'intersect' 'union' 'except'
%right 'or'
%right 'and'
%nonassoc 'not'
%left 'to'
%left '=' '<' '>' '<=' '>=' '!=' '>>' '<<' 'is' 'eq' 'ne' 'lt' 'le' 'gt' 'ge'
%left '+' '-'
%left '*' 'div' 'idiv' 'mod'
%nonassoc UMINUS
%%
prog :: { [ Ast ] }
prog : def { [$1] }
| def 'XMLtext' { [$1] }
| prog ';' def { $1++[$3] }
| prog ';' def 'XMLtext' { $1++[$3] }
def :: { Ast }
def : expr { $1 }
| 'declare' 'variable' var ':=' expr { Ast "variable" [$3,$5] }
| 'declare' 'function' 'QName'
'(' params ')' '{' expr '}' { Ast "function" ([Avar $3,$8]++$5) }
| 'declare' 'function' 'QName'
'(' ')' '{' expr '}' { Ast "function" [Avar $3,$7] }
params :: { [ Ast ] }
params : var { [$1] }
| params ',' var { $1++[$3] }
var :: { Ast }
var : 'Variable' { Avar $1 }
expr :: { Ast }
expr : clauses opt_where opt_order
'return' expr { (snd $3) ($1 ($2 ((fst $3) $5))) }
| 'some' for_bindings
'satisfies' expr { call "some" [$2 $4] }
| 'every' for_bindings
'satisfies' expr { call "not" [call "some" [$2 (call "not" [$4])]] }
| 'if' expr 'then' expr 'else' expr { call "if" [$2,$4,$6] }
| full_path { $1 }
| element { $1 }
| computed { $1 }
| expr 'to' expr { call "to" [$1,$3] }
| expr '+' expr { call "+" [$1,$3] }
| expr '-' expr { call "-" [$1,$3] }
| expr '*' expr { call "*" [$1,$3] }
| expr 'div' expr { call "div" [$1,$3] }
| expr 'idiv' expr { call "idiv" [$1,$3] }
| expr 'mod' expr { call "mod" [$1,$3] }
| expr '=' expr { call "=" [$1,$3] }
| expr '!=' expr { call "!=" [$1,$3] }
| expr '<' expr { call "<" [$1,$3] }
| expr '<=' expr { call "<=" [$1,$3] }
| expr '>' expr { call ">" [$1,$3] }
| expr '>=' expr { call ">=" [$1,$3] }
| expr '<<' expr { call "<<" [$1,$3] }
| expr '>>' expr { call ">>" [$1,$3] }
| expr 'is' expr { call "is" [$1,$3] }
| expr 'eq' expr { call "eq" [$1,$3] }
| expr 'ne' expr { call "ne" [$1,$3] }
| expr 'lt' expr { call "lt" [$1,$3] }
| expr 'le' expr { call "le" [$1,$3] }
| expr 'gt' expr { call "gt" [$1,$3] }
| expr 'ge' expr { call "ge" [$1,$3] }
| expr 'and' expr { call "and" [$1,$3] }
| expr 'or' expr { call "or" [$1,$3] }
| expr 'not' expr { call "not" [$1,$3] }
| expr 'union' expr { call "union" [$1,$3] }
| expr 'intersect' expr { call "intersect" [$1,$3] }
| expr 'except' expr { call "except" [$1,$3] }
| '+' expr %prec UMINUS { call "uplus" [$2] }
| '-' expr %prec UMINUS { call "uminus" [$2] }
| 'not' expr %prec UMINUS { call "not" [$2] }
| 'String' { Astring $1 }
| 'Integer' { Aint $1 }
| 'Double' { Afloat $1 }
expl :: { [ Ast ] }
expl : expr { [$1] }
| expl ',' expr { $1++[$3] }
clauses :: { Ast -> Ast }
clauses : 'for' for_bindings { $2 }
| 'let' let_bindings { $2 }
| clauses 'for' for_bindings { $1 . $3 }
| clauses 'let' let_bindings { $1 . $3 }
for_bindings :: { Ast -> Ast }
for_bindings : var 'in' expr { \x -> Ast "for" [$1,Avar "$",$3,x] }
| var 'at' var 'in' expr { \x -> Ast "for" [$1,$3,$5,x] }
| for_bindings ',' var 'in' expr { \x -> $1(Ast "for" [$3,Avar "$",$5,x]) }
| for_bindings ',' var 'at' var
'in' expr { \x -> $1(Ast "for" [$3,$5,$7,x]) }
let_bindings :: { Ast -> Ast }
let_bindings : var ':=' expr { \x -> Ast "let" [$1,$3,x] }
| let_bindings ','
var ':=' expr { \x -> $1(Ast "let" [$3,$5,x]) }
opt_where :: { Ast -> Ast }
opt_where : 'where' expr { \x -> Ast "predicate" [$2,x] }
| {- empty -} { id }
opt_order :: { ( Ast -> Ast, Ast -> Ast ) }
opt_order : 'order' 'by' order_list { (\x -> Ast "sortTuple" (x:(fst $3)),
\x -> Ast "sort" (x:(snd $3))) }
| {- empty -} { (id,id) }
order_list :: { ( [ Ast ], [ Ast ] ) }
order_list : expr mode { ([$1],[$2]) }
| order_list ',' expr mode { ((fst $1)++[$3],(snd $1)++[$4]) }
mode :: { Ast }
mode : 'ascending' { Avar "ascending" }
| 'descending' { Avar "descending" }
| {- empty -} { Avar "ascending" }
computed :: { Ast }
computed : 'element' '(' 'QName' ')' { call "element" [Avar $3] }
| 'attribute' '(' 'QName' ')' { call "attribute" [Avar $3] }
element :: { Ast }
element : stag '>' content '</' 'QName' '>' { if head $1 == Astring $5
then Ast "construction" ($1++[concatAll $3])
else error("Unmatched tags in element construction: "++(show (head $1))++" '"++$5++"'") }
| stag '>' '</' 'QName' '>' { if head $1 == Astring $4
then Ast "construction" ($1++[call "empty" []])
else error("Unmatched tags in element construction: "++(show (head $1))++" '"++$4++"'") }
| stag '/>' { Ast "construction" ($1++[call "empty" []]) }
| 'element' '{' expr '}' '{' expl '}' { Ast "element_construction" [$3,concatenateAll $6] }
| 'attribute' '{' expr '}''{' expl '}'{ Ast "attribute_construction" [$3,concatenateAll $6] }
| 'element' 'QName' '{' expl '}' { Ast "element_construction" [Astring $2,concatenateAll $4] }
| 'attribute' 'QName' '{' expl '}' { Ast "attribute_construction" [Astring $2,concatenateAll $4] }
stag :: { [ Ast ] }
stag : '<' 'QName' { [Astring $2,Ast "attributes" []] }
| '<' 'QName' attributes { [Astring $2,Ast "attributes" $3] }
content :: { [ Ast ] }
content : '{' expl '}' { [concatenateAll $2] }
| 'String' { [Astring $1] }
| 'XMLtext' { [Astring $1] }
| element { [$1] }
| content '{' expl '}' { $1++[concatenateAll $3] }
| content 'String' { $1++[Astring $2] }
| content 'XMLtext' { $1++[Astring $2] }
| content element { $1++[$2] }
attributes :: { [ Ast ] }
attributes : 'QName' '=' 'String' { [Ast "pair" [Astring $1,Astring $3]] }
| 'QName' '=' '\'{' expr '}\'' { [Ast "pair" [Astring $1,$4]] }
| attributes 'QName' '=' 'String' { $1++[Ast "pair" [Astring $2,Astring $4]] }
| attributes 'QName' '='
'\'{' expr '}\'' { $1++[Ast "pair" [Astring $2,$5]] }
full_path :: { Ast }
full_path : predicate_step { Ast "step" ($1 "child_step" (Avar ".")) }
| '@' predicate_step { Ast "step" ($2 "attribute_step" (Avar ".")) }
| predicate_step path { Ast "step" [$2 (Ast "step" ($1 "child_step" (Avar ".")))] }
| '@' predicate_step path { Ast "step" (map $3 ($2 "attribute_step" (Avar "."))) }
path :: { Ast -> Ast }
path : step { $1 }
| path step { $2 . $1 }
step :: { Ast -> Ast }
step : '/' predicate_step { \e -> Ast "step" ($2 "child_step" e) }
| '/' '@' predicate_step { \e -> Ast "step" ($3 "attribute_step" e) }
| '/' '/' predicate_step { \e -> Ast "step" ($3 "descendant_step" e) }
| '/' '/' '@' predicate_step { \e -> Ast "step" ($4 "attribute_descendant_step" e) }
| '/' '..' { \e -> Ast "step" [Ast "parent_step" [e]] }
predicate_step :: { String -> Ast -> [ Ast ] }
predicate_step : simple_step { \t e -> [$1 t e] }
| predicate_step '[' expr ']' { \t e -> ($1 t e)++[$3] }
simple_step :: { String -> Ast -> Ast }
simple_step : primary_expr { \t e -> $1 t e }
| '*' { \t e -> Ast t [Astring "*",e] }
| 'QName' { \t e -> Ast t [Astring $1,e] }
primary_expr :: { String -> Ast -> Ast }
primary_expr : var { \_ _ -> $1 }
| '.' { \_ e -> e }
| '(' expl ')' { \t e -> if e == Avar "."
then concatenateAll $2
else Ast "context" [e,Astring t,concatenateAll $2] }
| '(' ')' { \_ _ -> call "empty" [] }
| 'QName' '(' expl ')' { \_ e -> if e == Avar "."
then call $1 $3
else Ast "context" [e,call $1 $3] }
| 'QName' '(' ')' { if elem $1 ["text"]
then \_ e -> call $1 [e]
else \_ _ -> call $1 [] }
{
-- Abstract Syntax Tree for XQueries
data Ast = Ast String [Ast]
| Avar String
| Aint Int
| Afloat Float
| Astring String
deriving Eq
instance Show Ast
where show (Ast s []) = s ++ "()"
show (Ast s (x:xs)) = s ++ "(" ++ (show x)
++ (foldr (\a r -> ","++(show a)++r) "" xs)
++ ")"
show (Avar s) = s
show (Aint n) = show n
show (Afloat n) = show n
show (Astring s) = "\'" ++ s ++ "\'"
call :: String -> [Ast] -> Ast
call name args = Ast "call" ((Avar name):args)
concatenateAll :: [Ast] -> Ast
concatenateAll (x:xs) = foldl (\a r -> call "concatenate" [a,r]) x xs
concatenateAll _ = call "empty" []
concatAll :: [Ast] -> Ast
concatAll (x:xs) = foldl (\a r -> call "concat" [a,r]) x xs
concatAll _ = call "empty" []
data Token
= RETURN | SOME | EVERY | IF | THEN | ELSE | LB | RB | LP | RP | LSB | RSB
| LESCAPE | RESCAPE | TO | PLUS | MINUS | TIMES | DIV | IDIV | MOD
| TEQ | TNE | TLT | TLE | TGT | TGE | SEQ | SNE | SLT | SLE | SGT | SGE
| AND | OR | NOT | UNION | INTERSECT | EXCEPT | FOR | LET | IN | COMMA
| ASSIGN | WHERE | ORDER | BY | ASCENDING | DESCENDING | ELEMENT
| ATTRIBUTE | STAG | ETAG | SATISFIES | ATSIGN | SLASH | DECLARE | SEMI
| FUNCTION | VARIABLE |AT | DOT | DOTS | TokenEOF | PRE | POST | IS
| QName String | Variable String | XMLtext String | TInteger Int
| TFloat Float | TString String | TError String
deriving Eq
instance Show Token
where show (QName s) = "QName("++s++")"
show (Variable s) = "Variable("++s++")"
show (XMLtext s) = "XMLtext("++s++")"
show (TInteger n) = "Integer("++(show n)++")"
show (TFloat n) = "Double("++(show n)++")"
show (TString s) = "String("++s++")"
show t = case filter (\(n,_) -> n==t) tokenList of
(_,b):_ -> b
_ -> "Illegal token"
tokenList :: [(Token,String)]
tokenList = [(RETURN,"return"),(SOME,"some"),(EVERY,"every"),(IF,"if"),(THEN,"then"),(ELSE,"else"),
(LB,"["),(RB,"]"),(LP,"("),(RP,")"),(LSB,"{"),(RSB,"}"),(LESCAPE,"\"{"),(RESCAPE,"}\""),
(TO,"to"),(PLUS,"+"),(MINUS,"-"),(TIMES,"*"),(DIV,"div"),(IDIV,"idiv"),(MOD,"mod"),
(TEQ,"="),(TNE,"!="),(TLT,"<"),(TLE,"<="),(TGT,">"),(TGE,">="),(PRE,"<<"),(POST,">>"),
(IS,"is"),(SEQ,"eq"),(SNE,"ne"),(SLT,"lt"),(SLE,"le"),(SGT,"gt"),(SGE,"ge"),(AND,"and"),
(OR,"or"),(NOT,"not"),(UNION,"union"),(INTERSECT,"intersect"),(EXCEPT,"except"),
(FOR,"for"),(LET,"let"),(IN,"in"),(COMMA,"','"),(ASSIGN,":="),(WHERE,"where"),(ORDER,"order"),
(BY,"by"),(ASCENDING,"ascending"),(DESCENDING,"descending"),(ELEMENT,"element"),
(ATTRIBUTE,"attribute"),(STAG,"</"),(ETAG,"/>"),(SATISFIES,"satisfies"),(ATSIGN,"@"),
(SLASH,"/"),(DECLARE,"declare"),(FUNCTION,"function"),(VARIABLE,"variable"),
(AT,"at"),(DOTS,".."),(DOT,"."),(SEMI,";")]
parseError [] = error "Reached end-of-input"
parseError [_] = error "Reached end-of-input"
parseError tk = error("Parse error: "++(show (take 10 (init tk))))
scan :: String -> [Token]
scan cs = lexer cs [0]
xmlText :: String -> [Token]
xmlText "" = []
xmlText text = [XMLtext text]
-- scans XML syntax and returns an XMLtext token with the text
xml :: String -> String -> [Int] -> [Token]
xml ('{':cs) text n = (xmlText text)++(LSB : lexer cs (0:n))
xml ('<':'/':cs) text n = (xmlText text)++(STAG : lexer cs n)
xml ('<':'!':'-':cs) text n = xmlComment cs (text++"<!-") n
xml ('<':cs) text (k:n) = (xmlText text)++(TLT : lexer cs (k+2:n))
xml ('\'':'{':cs) text n = (xmlText text)++(LESCAPE : lexer cs n)
xml ('\"':'{':cs) text n = (xmlText text)++(LESCAPE : lexer cs n)
xml ('(':':':cs) text n = xqComment cs text n
xml (c:cs) text n = xml cs (text++[c]) n
xml [] text _ = xmlText text
xqComment :: String -> String -> [Int] -> [Token]
xqComment (':':')':cs) text n = xml cs text n
xqComment (_:cs) text n = xqComment cs text n
xqComment [] text _ = xmlText text
xmlComment :: String -> String -> [Int] -> [Token]
xmlComment ('-':'>':cs) text n = xml cs (text++"->") n
xmlComment (c:cs) text n = xmlComment cs (text++[c]) n
xmlComment [] text _ = xmlText text
isQN :: Char -> Bool
isQN c = elem c "_:-" || isDigit c || isAlpha c
isVar :: Char -> Bool
isVar c = elem c "_" || isDigit c || isAlpha c
-- the XQuery scanner
lexer :: String -> [Int] -> [Token]
lexer [] [0] = []
lexer [] _ = error "Unbalanced tags"
lexer (' ':'>':' ':cs) n = TGT : lexer cs n
lexer (c:cs) n
| isSpace c = lexer cs n
| isAlpha c = lexVar (c:cs) n
| isDigit c = lexNum (c:cs) n
lexer ('$':c:cs) n | isAlpha c
= let (var,rest) = span isVar (c:cs)
in (Variable var) : lexer rest n
lexer ('\'':'{':cs) n = LESCAPE : lexer cs n
lexer ('\"':'{':cs) n = LESCAPE : lexer cs n
lexer (':':'=':cs) n = ASSIGN : lexer cs n
lexer ('<':'/':cs) n = STAG : lexer cs n
lexer ('<':'=':cs) n = TLE : lexer cs n
lexer ('>':'=':cs) n = TGE : lexer cs n
lexer ('<':'<':cs) n = PRE : lexer cs n
lexer ('>':'>':cs) n = POST : lexer cs n
lexer ('/':'>':cs) (k:n) = ETAG : lexer cs (k-2:n)
lexer ('(':':':cs) n = lexComment cs n
lexer ('<':'!':'-':cs) n = lexXmlComment cs "<!-" n
lexer ('.':'.':cs) n = DOTS : lexer cs n
lexer ('.':cs) n = DOT : lexer cs n
lexer ('}':'\'':cs) n = RESCAPE : lexer cs n
lexer ('}':'\"':cs) n = RESCAPE : lexer cs n
lexer ('!':'=':cs) n = TNE : lexer cs n
lexer ('\'':cs) n = lexString cs n
lexer ('\"':cs) n = lexString2 cs n
lexer ('[':cs) n = LB : lexer cs n
lexer (']':cs) n = RB : lexer cs n
lexer ('(':cs) n = LP : lexer cs n
lexer (')':cs) n = RP : lexer cs n
lexer ('}':cs) [_,n] = RSB : lexer cs [n]
lexer ('}':cs) (_:n:ns) = RSB : (if n==0 then lexer cs (n:ns) else xml cs "" (n:ns))
lexer ('+':cs) n = PLUS : lexer cs n
lexer ('-':cs) n = MINUS : lexer cs n
lexer ('*':cs) n = TIMES : lexer cs n
lexer ('=':cs) n = TEQ : lexer cs n
lexer ('<':c:cs) n | not(isAlpha c) = TLT : lexer (c:cs) n
lexer ('<':cs) (k:n) = TLT : lexer cs (k+2:n)
lexer ('>':cs) (k:n) = TGT : (if k==1 then lexer cs (0:n) else xml cs "" (k-1:n))
lexer (',':cs) n = COMMA : lexer cs n
lexer ('@':cs) n = ATSIGN : lexer cs n
lexer ('/':cs) n = SLASH : lexer cs n
lexer ('{':cs) n = LSB : lexer cs (0:n)
lexer ('|':cs) n = UNION : lexer cs n
lexer (';':cs) n = SEMI : lexer cs n
lexer (c:cs) n = error("Illegal character "++[c])
lexNum :: String -> [Int] -> [Token]
lexNum cs n = if null rest || head rest /= '.'
then TInteger (read k) : lexer rest n
else let (m,rest2) = span isDigit (tail rest)
val::Float = read (k++('.':m))
in case rest2 of
('e':rest3) -> let (exp,rest4) = span isDigit rest3
in (TFloat (val*10^(read exp))) : lexer rest4 n
_ -> (TFloat val) : lexer rest2 n
where (k,rest) = span isDigit cs
lexString :: String -> [Int] -> [Token]
lexString cs n = TString s : lexer (tail rest) n
where (s,rest) = span inString cs
inString c = c /= '\''
lexString2 :: String -> [Int] -> [Token]
lexString2 cs n = TString s : lexer (tail rest) n
where (s,rest) = span inString cs
inString c = c /= '\"'
lexComment :: String -> [Int] -> [Token]
lexComment (':':')':cs) n = lexer cs n
lexComment (_:cs) n = lexComment cs n
lexComment [] n = []
lexXmlComment :: String -> String -> [Int] -> [Token]
lexXmlComment ('-':'>':cs) text n = (xmlText (text++"->"))++(lexer cs n)
lexXmlComment (c:cs) text n = lexXmlComment cs (text++[c]) n
lexXmlComment [] text _ = xmlText text
lexVar :: String -> [Int] -> [Token]
lexVar cs n =
case span isQN cs of
("return",rest) -> RETURN : lexer rest n
("some",rest) -> SOME : lexer rest n
("every",rest) -> EVERY : lexer rest n
("if",rest) -> IF : lexer rest n
("then",rest) -> THEN : lexer rest n
("else",rest) -> ELSE : lexer rest n
("to",rest) -> TO : lexer rest n
("div",rest) -> DIV : lexer rest n
("idiv",rest) -> IDIV : lexer rest n
("mod",rest) -> MOD : lexer rest n
("and",rest) -> AND : lexer rest n
("or",rest) -> OR : lexer rest n
("not",rest) -> NOT : lexer rest n
("union",rest) -> UNION : lexer rest n
("intersect",rest) -> INTERSECT : lexer rest n
("except",rest) -> EXCEPT : lexer rest n
("for",rest) -> FOR : lexer rest n
("let",rest) -> LET : lexer rest n
("in",rest) -> IN : lexer rest n
("where",rest) -> WHERE : lexer rest n
("order",rest) -> ORDER : lexer rest n
("by",rest) -> BY : lexer rest n
("ascending",rest) -> ASCENDING : lexer rest n
("descending",rest) -> DESCENDING : lexer rest n
("element",rest) -> ELEMENT : lexer rest n
("attribute",rest) -> ATTRIBUTE : lexer rest n
("satisfies",rest) -> SATISFIES : lexer rest n
("declare",rest) -> DECLARE : lexer rest n
("function",rest) -> FUNCTION : lexer rest n
("variable",rest) -> VARIABLE : lexer rest n
("at",rest) -> AT : lexer rest n
("eq",rest) -> SEQ : lexer rest n
("ne",rest) -> SNE : lexer rest n
("lt",rest) -> SLT : lexer rest n
("le",rest) -> SLE : lexer rest n
("gt",rest) -> SGT : lexer rest n
("ge",rest) -> SGE : lexer rest n
("is",rest) -> IS : lexer rest n
(var,rest) -> QName var : lexer rest n
}