(*                                                                           *)
(* Dynamic web page generation with Standard ML                              *)
(* Copyright (C) 2003  Adam Chlipala                                         *)
(*                                                                           *)
(* This library is free software; you can redistribute it and/or             *)
(* modify it under the terms of the GNU Lesser General Public                *)
(* License as published by the Free Software Foundation; either              *)
(* version 2.1 of the License, or (at your option) any later version.        *)
(*                                                                           *)
(* This library is distributed in the hope that it will be useful,           *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of            *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU         *)
(* Lesser General Public License for more details.                           *)
(*                                                                           *)
(* You should have received a copy of the GNU Lesser General Public          *)
(* License along with this library; if not, write to the Free Software       *)
(* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA *)

(* Grammar for ML template language *)

open Tree

fun rcomp ((a, _), (b, _)) = String.compare (a, b) = GREATER
fun sortRcs x = ListMergeSort.sort rcomp x

fun addNumbers L =
	let
		fun addNum (_, []) = []
		  | addNum (n, h::t) = (Int.toString n, h)::(addNum(n+1,t))
	in	
		addNum (1, L)
	end


%%
%header (functor MltLrValsFn(structure Token : TOKEN))

%term 
   EOF
 | HTML of string
 | IF | THEN | ELSE
 | AS | WITH | OPEN | VAL | REF | TRY | CATCH
 | FN | END | RAISE
 | FOREACH | IN | DO
 | SWITCH | CASE | OF | BAR | ARROW
 | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE | HASH | SEMI | CONS
 | PLUS | MINUS | TIMES | DIVIDE | MOD | NEG | DOLLAR | AT | STRCAT
 | ASN | EQ | NEQ | GT | GTE | LT | LTE
 | ANDALSO | ORELSE
 | IDENT of string | DOT | DOTDOT | DOTDOTDOT | COMMA | COLON | CARET | TILDE | UNDER
 | INT of int | STRING of string | CHAR of string | REAL of real

%nonterm 
   file of block
 | block of block
 | exp of exp
 | cases of (pat * exp) list
 | appsL of exp list
 | apps of exp
 | term of exp
 | pterm of pat
 | papp of pat
 | pat of pat
 | path of ident list
 | pathList of ident list list
 | blockItem of blockItem
 | elseOpt of block option
 | matches of (pat * block) list withext
 | pexp of exp
 | ppat of pat
 | pseq of pat list
 | rseq of (ident * pat) list
 | frseq of (ident * pat) list
 | eseq of exp list
 | elseq of exp list
 | plseq of pat list
 | erseq of (ident * exp) list
 | ilist of ident list
 | ivlist of (ident * exp) list
 | catch of pat * block
 | catches of (pat * block) list

%verbose                                (* print summary of errors *)
%pos int                                (* positions *)
%start file
%pure
%eop EOF
%noshift EOF

%name Mlt

%left ANDALSO
%left ORELSE
%nonassoc EQ NEQ GT GTE LT LTE
%left PLUS MINUS
%left TIMES DIVIDE MOD
%left STRCAT
%nonassoc NEG
%right CONS

%%

file 	: block				(block)

ilist	: IDENT ilist			(IDENT :: ilist)
	| IDENT				([IDENT])

ivlist	: IDENT EQ exp COMMA ivlist	((IDENT, exp) :: ivlist)
	| IDENT EQ exp			([(IDENT, exp)])

catch	: pat ARROW block	        (pat, block)

catches	: catches BAR catch		(catch::catches)
	| catch				([catch])

blockItem	: HTML			(BITEM (Html_i HTML, (HTMLleft, HTMLright)))
		| REF ivlist		(BITEM (Ref_i ivlist, (REFleft, ivlistright)))
		| OPEN pathList		(BITEM (Open_i pathList, (OPENleft, pathListright)))
		| VAL pat EQ exp	(BITEM (Val_i (pat, exp), (patleft, expright)))
		| IDENT ASN exp		(BITEM (Assn_i (IDENT, exp), (IDENTleft, expright)))
		| exp			(BITEM (Exp_i exp, (expleft, expright)))
		| IF exp THEN block elseOpt END
                        (BITEM (Ifthenelse_i(exp, block, elseOpt),
				(IFleft, ENDright)))
		| FOREACH IDENT IN exp DO block END
			(BITEM (Foreach_i (IDENT, exp, block),
				(FOREACHleft, ENDright)))
		| FOREACH IDENT IN exp DOTDOT exp DO block END
			(BITEM (For_i (IDENT, exp1, exp2, block),
			 	(FOREACHleft, ENDright)))
		| SWITCH exp OF matches END
			(BITEM (Case_i (exp, List.rev (#1 matches)), (SWITCHleft, ENDright)))
		| TRY block WITH catches END
			(BITEM (TryCatch_i (block, List.rev catches), (TRYleft, ENDright)))

elseOpt         :                       (NONE)
                | ELSE block            (SOME block)

block	: blockItem			(BLOCK ([blockItem], (blockItemleft, blockItemright)))
	| blockItem SEMI block		(BLOCK (blockItem :: (unblock block), (blockItemleft, blockright)))
	| blockItem block		(BLOCK (blockItem :: (unblock block), (blockItemleft, blockright)))
	| SEMI block			(block)
	|				(BLOCK ([], (0, 0)))

appsL	: term appsL			(term::appsL)
	| term				([term])

apps	: appsL				(let
						val e::r = appsL
					in
						foldl (fn (e, a) => EXP (App_e (a, e), (appsLleft, appsLright))) e r
					end)


path	: IDENT DOT path		(IDENT::path)
	| IDENT				([IDENT])

pathList: path pathList                 (path::pathList)
        | path                          ([path])

eseq	: exp COMMA eseq		(exp :: eseq)
	| exp COMMA exp			([exp1, exp2])

elseq	: eseq				(eseq)
	| exp				([exp])
	|				([])

erseq	: IDENT EQ exp COMMA erseq	((IDENT, exp) :: erseq)
	| IDENT COMMA erseq		((IDENT, EXP (Ident_e [IDENT], (IDENTleft, IDENTright))) :: erseq)
	| IDENT				([(IDENT, EXP (Ident_e [IDENT], (IDENTleft, IDENTright)))])
	| IDENT EQ exp			([(IDENT, exp)])

pexp	: LPAREN eseq RPAREN		(EXP (Record_e (true, addNumbers eseq), (LPARENleft, LPARENright)))
	| LPAREN RPAREN			(EXP (Record_e (true, []), (LPARENleft, RPARENright)))
	| LPAREN exp RPAREN		(exp)

term	: LBRACE erseq RBRACE		(EXP (Record_e (false, sortRcs erseq), (LBRACEleft, RBRACEright)))
	| LBRACE RBRACE			(EXP (Record_e (false, []), (LBRACEleft, RBRACEright)))
	| LBRACE term WITH erseq RBRACE	(EXP (RecordUpd_e (term, erseq), (LBRACEleft, RBRACEright)))
	| pexp				(pexp)
	| STRING			(EXP (String_e STRING, (STRINGleft, STRINGright)))
	| CHAR                          (EXP (Char_e CHAR, (CHARleft, CHARright)))
	| REAL                          (EXP (Real_e REAL, (REALleft, REALright)))
	| path				(EXP (Ident_e path, (pathleft, pathright)))
	| INT				(EXP (Int_e INT, (INTleft, INTright)))
	| NEG				(EXP (Neg_e, (NEGleft, NEGright)))
	| DOLLAR                        (EXP (Param_e, (DOLLARleft, DOLLARright)))
	| AT IDENT                      (EXP (Template_e IDENT, (ATleft, IDENTright)))
	| HASH INT			(EXP (Proj_e (Int.toString INT), (HASHleft, INTright)))
	| HASH IDENT			(EXP (Proj_e IDENT, (HASHleft, IDENTright)))
	| LBRACK elseq RBRACK		(foldr (fn x => EXP (Cons_e x, (LBRACKleft, RBRACKright)))
						(EXP (Ident_e ["nil"], (0, 0))) elseq)

exp	: apps				(apps)
	| exp PLUS exp			(EXP (Plus_e (exp1, exp2), (exp1left, exp2right)))
	| exp MINUS exp			(EXP (Minus_e (exp1, exp2), (exp1left, exp2right)))
	| exp TIMES exp			(EXP (Times_e (exp1, exp2), (exp1left, exp2right)))
	| exp DIVIDE exp		(EXP (Divide_e (exp1, exp2), (exp1left, exp2right)))
	| exp MOD exp			(EXP (Mod_e (exp1, exp2), (exp1left, exp2right)))
	| exp EQ exp			(EXP (Eq_e (exp1, exp2), (exp1left, exp2right)))
	| exp NEQ exp			(EXP (Neq_e (exp1, exp2), (exp1left, exp2right)))
	| exp LT exp			(EXP (Lt_e (exp1, exp2), (exp1left, exp2right)))
	| exp LTE exp 			(EXP (Lte_e (exp1, exp2), (exp1left, exp2right)))
	| exp GT exp			(EXP (Gt_e (exp1, exp2), (exp1left, exp2right)))
	| exp GTE exp			(EXP (Gte_e (exp1, exp2), (exp1left, exp2right)))
	| exp CONS exp			(EXP (Cons_e (exp1, exp2), (exp1left, exp2right)))
	| exp STRCAT exp		(EXP (StrCat_e (exp1, exp2), (exp1left, exp2right)))
	| exp ORELSE exp		(EXP (Orelse_e (exp1, exp2), (exp1left, exp2right)))
	| exp ANDALSO exp		(EXP (Andalso_e (exp1, exp2), (exp1left, exp2right)))
        | CASE exp OF cases             (EXP (Case_e (exp, List.rev cases), (expleft, casesright)))
        | FN cases                      (EXP (Fn_e (List.rev cases), (FNleft, casesright)))
        | RAISE exp                     (EXP (Raise_e exp, (RAISEleft, expright)))


cases   : pat ARROW exp                 ([(pat, exp)])
        | cases BAR pat ARROW exp       ((pat, exp) :: cases)

matches	: matches BAR pat ARROW block	        (((pat, block) :: (#1 matches), (matchesleft, blockright)))
	| pat ARROW block			([(pat, block)], (patleft, blockright))

rseq	: IDENT EQ pat COMMA rseq		((IDENT, pat) :: rseq)
	| IDENT COMMA rseq			((IDENT, PAT (Ident_p [IDENT], (IDENTleft, IDENTright))) :: rseq)
	| IDENT					([(IDENT, PAT (Ident_p [IDENT], (IDENTleft, IDENTright)))])
	| IDENT EQ pat				([(IDENT, pat)])

frseq	: IDENT EQ pat COMMA frseq		((IDENT, pat) :: frseq)
	| IDENT COMMA frseq			((IDENT, PAT (Ident_p [IDENT], (IDENTleft, IDENTright))) :: frseq)
	| DOTDOTDOT				([])

ppat	: LPAREN pat RPAREN			(PAT (unpat pat, (LPARENleft, RPARENright)))
	| LPAREN pseq RPAREN			(PAT (Record_p (true, addNumbers pseq), (LPARENleft, LPARENright)))
	| LPAREN RPAREN				(PAT (Record_p (true, []), (LPARENleft, RPARENright)))

pseq	: pat COMMA pseq			(pat :: pseq)
	| pat COMMA pat				([pat1, pat2])

plseq	: pseq			 	        (pseq)
	| pat				        ([pat])
	|			  	        ([])

pterm	: path					(PAT (Ident_p path, (pathleft, pathright)))
	| UNDER					(PAT (Wild_p, (UNDERleft, UNDERright)))
	| INT					(PAT (Int_p INT, (INTleft, INTright)))
	| STRING				(PAT (String_p STRING, (STRINGleft, STRINGright)))
	| CHAR				        (PAT (Char_p CHAR, (CHARleft, CHARright)))
	| REAL				        (PAT (Real_p REAL, (REALleft, REALright)))
	| LBRACE rseq RBRACE			(PAT (Record_p (false, sortRcs rseq), (LBRACEleft, RBRACEright)))
	| LBRACE RBRACE				(PAT (Record_p (false, []), (LBRACEleft, RBRACEright)))
	| LBRACE frseq RBRACE			(PAT (FlexRecord_p (sortRcs frseq), (LBRACEleft, RBRACEright)))
	| ppat					(ppat)

papp	: path papp				(PAT (App_p (path, papp), (pathleft, pappright)))
	| pterm					(pterm)

pat	: papp CONS papp			(PAT (Cons_p (papp1, papp2), (papp1left, papp2right)))
	| papp					(papp)
	| IDENT AS pat				(PAT (As_p (IDENT, pat), (IDENTleft, patright)))
	| LBRACK plseq RBRACK			(foldr (fn x => PAT (Cons_p x, (LBRACKleft, RBRACKright)))
							(PAT (Ident_p ["nil"], (0, 0))) plseq)