adamc@1: (* Copyright (c) 2008, Adam Chlipala
adamc@1:  * All rights reserved.
adamc@1:  *
adamc@1:  * Redistribution and use in source and binary forms, with or without
adamc@1:  * modification, are permitted provided that the following conditions are met:
adamc@1:  *
adamc@1:  * - Redistributions of source code must retain the above copyright notice,
adamc@1:  *   this list of conditions and the following disclaimer.
adamc@1:  * - Redistributions in binary form must reproduce the above copyright notice,
adamc@1:  *   this list of conditions and the following disclaimer in the documentation
adamc@1:  *   and/or other materials provided with the distribution.
adamc@1:  * - The names of contributors may not be used to endorse or promote products
adamc@1:  *   derived from this software without specific prior written permission.
adamc@1:  *
adamc@1:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@1:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@1:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@1:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@1:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adamc@1:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@1:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@1:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@1:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@1:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@1:  * POSSIBILITY OF SUCH DAMAGE.
adamc@1:  *)
adamc@1: 
adamc@1: (* Grammar for Laconic/Web programs *)
adamc@1: 
adamc@4: open Source
adamc@1: 
adamc@1: val s = ErrorMsg.spanOf
adamc@1: 
adamc@104: fun uppercaseFirst "" = ""
adamc@104:   | uppercaseFirst s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adamc@104: 
adamc@1: %%
adamc@1: %header (functor LacwebLrValsFn(structure Token : TOKEN))
adamc@1: 
adamc@1: %term 
adamc@1:    EOF
adamc@14:  | STRING of string | INT of Int64.int | FLOAT of Real64.real
adamc@1:  | SYMBOL of string | CSYMBOL of string
adamc@1:  | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
adamc@156:  | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR
adamc@174:  | DIVIDE | GT | DOTDOTDOT
adamc@123:  | CON | LTYPE | VAL | REC | AND | FOLD | UNIT | KUNIT
adamc@156:  | DATATYPE | OF
adamc@7:  | TYPE | NAME
adamc@1:  | ARROW | LARROW | DARROW
adamc@149:  | FN | PLUSPLUS | MINUSMINUS | DOLLAR | TWIDDLE
adamc@88:  | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN
adamc@109:  | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT
adamc@170:  | CASE
adamc@1: 
adamc@91:  | XML_BEGIN of string | XML_END
adamc@91:  | NOTAGS of string 
adamc@91:  | BEGIN_TAG of string | END_TAG of string
adamc@91: 
adamc@30: %nonterm
adamc@1:    file of decl list
adamc@1:  | decls of decl list
adamc@1:  | decl of decl
adamc@123:  | vali of string * con option * exp
adamc@123:  | valis of (string * con option * exp) list
adamc@1: 
adamc@156:  | barOpt of unit
adamc@156:  | dcons of (string * con option) list
adamc@156:  | dcon of string * con option
adamc@156: 
adamc@30:  | sgn of sgn
adamc@42:  | sgntm of sgn
adamc@30:  | sgi of sgn_item
adamc@30:  | sgis of sgn_item list
adamc@30: 
adamc@30:  | str of str
adamc@30: 
adamc@1:  | kind of kind
adamc@1:  | kcolon of explicitness
adamc@1: 
adamc@34:  | path of string list * string
adamc@156:  | cpath of string list * string
adamc@34:  | spath of str
adamc@59:  | mpath of string list
adamc@34: 
adamc@1:  | cexp of con
adamc@1:  | capps of con
adamc@1:  | cterm of con
adamc@1:  | ident of con
adamc@1:  | rcon of (con * con) list
adamc@83:  | rconn of (con * con) list
adamc@1:  | rcone of (con * con) list
adamc@1: 
adamc@8:  | eexp of exp
adamc@8:  | eapps of exp
adamc@8:  | eterm of exp
adamc@12:  | rexp of (con * exp) list
adamc@91:  | xml of exp
adamc@91:  | xmlOne of exp
adamc@141:  | tag of string * exp
adamc@141:  | tagHead of string * exp
adamc@8: 
adamc@170:  | branch of pat * exp
adamc@170:  | branchs of (pat * exp) list
adamc@170:  | pat of pat
adamc@170:  | pterm of pat
adamc@174:  | rpat of (string * pat) list * bool
adamc@170: 
adamc@104:  | attrs of (con * exp) list
adamc@104:  | attr of con * exp
adamc@104:  | attrv of exp
adamc@104: 
adamc@1: %verbose                                (* print summary of errors *)
adamc@1: %pos int                                (* positions *)
adamc@1: %start file
adamc@1: %pure
adamc@1: %eop EOF
adamc@1: %noshift EOF
adamc@1: 
adamc@1: %name Lacweb
adamc@1: 
adamc@1: %nonassoc DARROW
adamc@1: %nonassoc COLON
adamc@6: %nonassoc DCOLON TCOLON
adamc@1: %right COMMA
adamc@1: %right ARROW LARROW
adamc@149: %right PLUSPLUS MINUSMINUS
adamc@84: %nonassoc TWIDDLE
adamc@1: %nonassoc DOLLAR
adamc@1: %left DOT
adamc@1: 
adamc@1: %%
adamc@1: 
adamc@1: file   : decls                          (decls)
adamc@54:        | SIG sgis                       ([(DSgn ("?", (SgnConst sgis, s (SIGleft, sgisright))),
adamc@54:                                            s (SIGleft, sgisright))])
adamc@1: 
adamc@1: decls  :                                ([])
adamc@1:        | decl decls                     (decl :: decls)
adamc@1: 
adamc@1: decl   : CON SYMBOL EQ cexp             (DCon (SYMBOL, NONE, cexp), s (CONleft, cexpright))
adamc@1:        | CON SYMBOL DCOLON kind EQ cexp (DCon (SYMBOL, SOME kind, cexp), s (CONleft, cexpright))
adamc@7:        | LTYPE SYMBOL EQ cexp           (DCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
adamc@7:                                          s (LTYPEleft, cexpright))
adamc@156:        | DATATYPE SYMBOL EQ barOpt dcons(DDatatype (SYMBOL, dcons), s (DATATYPEleft, dconsright))
adamc@157:        | DATATYPE SYMBOL EQ DATATYPE CSYMBOL DOT path
adamc@157:                 (DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))
adamc@123:        | VAL vali                       (DVal vali, s (VALleft, valiright))
adamc@123:        | VAL REC valis                  (DValRec valis, s (VALleft, valisright))
adamc@1: 
adamc@30:        | SIGNATURE CSYMBOL EQ sgn       (DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))
adamc@30:        | STRUCTURE CSYMBOL EQ str       (DStr (CSYMBOL, NONE, str), s (STRUCTUREleft, strright))
adamc@30:        | STRUCTURE CSYMBOL COLON sgn EQ str (DStr (CSYMBOL, SOME sgn, str), s (STRUCTUREleft, strright))
adamc@42:        | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str
adamc@42:                                         (DStr (CSYMBOL1, NONE,
adamc@42:                                                (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))),
adamc@42:                                          s (FUNCTORleft, strright))
adamc@42:        | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str
adamc@42:                                         (DStr (CSYMBOL1, NONE,
adamc@42:                                                (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))),
adamc@42:                                          s (FUNCTORleft, strright))
adamc@48:        | EXTERN STRUCTURE CSYMBOL COLON sgn (DFfiStr (CSYMBOL, sgn), s (EXTERNleft, sgnright))
adamc@61:        | OPEN mpath                     (case mpath of
adamc@61:                                              [] => raise Fail "Impossible mpath parse [1]"
adamc@61:                                            | m :: ms => (DOpen (m, ms), s (OPENleft, mpathright)))
adamc@88:        | OPEN CONSTRAINTS mpath         (case mpath of
adamc@88:                                              [] => raise Fail "Impossible mpath parse [3]"
adamc@88:                                            | m :: ms => (DOpenConstraints (m, ms), s (OPENleft, mpathright)))
adamc@88:        | CONSTRAINT cterm TWIDDLE cterm (DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))
adamc@109:        | EXPORT spath                   (DExport spath, s (EXPORTleft, spathright))
adamc@30: 
adamc@156: barOpt :                                ()
adamc@156:        | BAR                            ()
adamc@156: 
adamc@156: dcons  : dcon                           ([dcon])
adamc@156:        | dcon BAR dcons                 (dcon :: dcons)
adamc@156: 
adamc@156: dcon   : CSYMBOL                        (CSYMBOL, NONE)
adamc@156:        | CSYMBOL OF cexp                (CSYMBOL, SOME cexp)
adamc@156: 
adamc@123: vali   : SYMBOL EQ eexp                 (SYMBOL, NONE, eexp)
adamc@123:        | SYMBOL COLON cexp EQ eexp      (SYMBOL, SOME cexp, eexp)
adamc@123: 
adamc@123: valis  : vali                           ([vali])
adamc@123:        | vali AND valis                 (vali :: valis)
adamc@123: 
adamc@42: sgn    : sgntm                          (sgntm)
adamc@40:        | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn
adamc@40:                                         (SgnFun (CSYMBOL, sgn1, sgn2), s (FUNCTORleft, sgn2right))
adamc@30: 
adamc@42: sgntm  : SIG sgis END                   (SgnConst sgis, s (SIGleft, ENDright))
adamc@59:        | mpath                          (case mpath of
adamc@61:                                              [] => raise Fail "Impossible mpath parse [2]"
adamc@59:                                            | [x] => SgnVar x
adamc@59:                                            | m :: ms => SgnProj (m,
adamc@59:                                                                  List.take (ms, length ms - 1),
adamc@59:                                                                  List.nth (ms, length ms - 1)),
adamc@59:                                          s (mpathleft, mpathright))
adamc@42:        | sgntm WHERE CON SYMBOL EQ cexp (SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright))
adamc@42:        | sgntm WHERE LTYPE SYMBOL EQ cexp(SgnWhere (sgntm, SYMBOL, cexp), s (sgntmleft, cexpright))
adamc@42:        | LPAREN sgn RPAREN              (sgn)
adamc@42: 
adamc@30: sgi    : CON SYMBOL DCOLON kind         (SgiConAbs (SYMBOL, kind), s (CONleft, kindright))
adamc@30:        | LTYPE SYMBOL                   (SgiConAbs (SYMBOL, (KType, s (LTYPEleft, SYMBOLright))),
adamc@30:                                          s (LTYPEleft, SYMBOLright))
adamc@30:        | CON SYMBOL EQ cexp             (SgiCon (SYMBOL, NONE, cexp), s (CONleft, cexpright))
adamc@30:        | CON SYMBOL DCOLON kind EQ cexp (SgiCon (SYMBOL, SOME kind, cexp), s (CONleft, cexpright))
adamc@30:        | LTYPE SYMBOL EQ cexp           (SgiCon (SYMBOL, SOME (KType, s (LTYPEleft, cexpright)), cexp),
adamc@30:                                          s (LTYPEleft, cexpright))
adamc@156:        | DATATYPE SYMBOL EQ barOpt dcons(SgiDatatype (SYMBOL, dcons), s (DATATYPEleft, dconsright))
adamc@157:        | DATATYPE SYMBOL EQ DATATYPE CSYMBOL DOT path
adamc@157:                 (SgiDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))
adamc@30:        | VAL SYMBOL COLON cexp          (SgiVal (SYMBOL, cexp), s (VALleft, cexpright))
adamc@30: 
adamc@30:        | STRUCTURE CSYMBOL COLON sgn    (SgiStr (CSYMBOL, sgn), s (STRUCTUREleft, sgnright))
adamc@59:        | SIGNATURE CSYMBOL EQ sgn       (SgiSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))
adamc@42:        | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn
adamc@42:                                         (SgiStr (CSYMBOL1,
adamc@42:                                                  (SgnFun (CSYMBOL2, sgn1, sgn2), s (FUNCTORleft, sgn2right))),
adamc@42:                                          s (FUNCTORleft, sgn2right))
adamc@58:        | INCLUDE sgn                    (SgiInclude sgn, s (INCLUDEleft, sgnright))
adamc@88:        | CONSTRAINT cterm TWIDDLE cterm (SgiConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))
adamc@30: 
adamc@30: sgis   :                                ([])
adamc@30:        | sgi sgis                       (sgi :: sgis)
adamc@30: 
adamc@30: str    : STRUCT decls END               (StrConst decls, s (STRUCTleft, ENDright))
adamc@34:        | spath                          (spath)
adamc@40:        | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN DARROW str
adamc@40:                                         (StrFun (CSYMBOL, sgn, NONE, str), s (FUNCTORleft, strright))
adamc@40:        | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn DARROW str
adamc@40:                                         (StrFun (CSYMBOL, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))
adamc@44:        | spath LPAREN str RPAREN        (StrApp (spath, str), s (spathleft, RPARENright))
adamc@34: 
adamc@34: spath  : CSYMBOL                        (StrVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@34:        | spath DOT CSYMBOL              (StrProj (spath, CSYMBOL), s (spathleft, CSYMBOLright))
adamc@30: 
adamc@1: kind   : TYPE                           (KType, s (TYPEleft, TYPEright))
adamc@1:        | NAME                           (KName, s (NAMEleft, NAMEright))
adamc@1:        | LBRACE kind RBRACE             (KRecord kind, s (LBRACEleft, RBRACEright))
adamc@1:        | kind ARROW kind                (KArrow (kind1, kind2), s (kind1left, kind2right))
adamc@1:        | LPAREN kind RPAREN             (#1 kind, s (LPARENleft, RPARENright))
adamc@82:        | KUNIT                          (KUnit, s (KUNITleft, KUNITright))
adamc@18:        | UNDERUNDER                     (KWild, s (UNDERUNDERleft, UNDERUNDERright))
adamc@1: 
adamc@1: capps  : cterm                          (cterm)
adamc@1:        | capps cterm                    (CApp (capps, cterm), s (cappsleft, ctermright))
adamc@1: 
adamc@1: cexp   : capps                          (capps)
adamc@1:        | cexp ARROW cexp                (TFun (cexp1, cexp2), s (cexp1left, cexp2right))
adamc@15:        | SYMBOL kcolon kind ARROW cexp  (TCFun (kcolon, SYMBOL, kind, cexp), s (SYMBOLleft, cexpright))
adamc@1: 
adamc@1:        | cexp PLUSPLUS cexp             (CConcat (cexp1, cexp2), s (cexp1left, cexp1right))
adamc@1: 
adamc@67:        | FN SYMBOL DARROW cexp          (CAbs (SYMBOL, NONE, cexp), s (FNleft, cexpright))
adamc@67:        | FN SYMBOL DCOLON kind DARROW cexp (CAbs (SYMBOL, SOME kind, cexp), s (FNleft, cexpright))
adamc@84:        | cterm TWIDDLE cterm DARROW cexp(CDisjoint (cterm1, cterm2, cexp), s (cterm1left, cexpright))
adamc@85:        | cterm TWIDDLE cterm ARROW cexp (TDisjoint (cterm1, cterm2, cexp), s (cterm1left, cexpright))
adamc@1: 
adamc@8:        | LPAREN cexp RPAREN DCOLON kind (CAnnot (cexp, kind), s (LPARENleft, kindright))
adamc@6: 
adamc@18:        | UNDER DCOLON kind              (CWild kind, s (UNDERleft, UNDERright))
adamc@18: 
adamc@1: kcolon : DCOLON                         (Explicit)
adamc@1:        | TCOLON                         (Implicit)
adamc@1: 
adamc@34: path   : SYMBOL                         ([], SYMBOL)
adamc@34:        | CSYMBOL DOT path               (let val (ms, x) = path in (CSYMBOL :: ms, x) end)
adamc@34: 
adamc@156: cpath  : CSYMBOL                        ([], CSYMBOL)
adamc@156:        | CSYMBOL DOT cpath              (let val (ms, x) = cpath in (CSYMBOL :: ms, x) end)
adamc@156: 
adamc@59: mpath  : CSYMBOL                        ([CSYMBOL])
adamc@59:        | CSYMBOL DOT mpath              (CSYMBOL :: mpath)
adamc@59: 
adamc@1: cterm  : LPAREN cexp RPAREN             (#1 cexp, s (LPARENleft, RPARENright))
adamc@1:        | LBRACK rcon RBRACK             (CRecord rcon, s (LBRACKleft, RBRACKright))
adamc@83:        | LBRACK rconn RBRACK            (CRecord rconn, s (LBRACKleft, RBRACKright))
adamc@1:        | LBRACE rcone RBRACE            (TRecord (CRecord rcone, s (LBRACEleft, RBRACEright)),
adamc@1: 					 s (LBRACEleft, RBRACEright))
adamc@1:        | DOLLAR cterm                   (TRecord cterm, s (DOLLARleft, ctermright))
adamc@1:        | HASH CSYMBOL                   (CName CSYMBOL, s (HASHleft, CSYMBOLright))
adamc@1: 
adamc@34:        | path                           (CVar path, s (pathleft, pathright))
adamc@18:        | UNDER                          (CWild (KWild, s (UNDERleft, UNDERright)), s (UNDERleft, UNDERright))
adamc@67:        | FOLD                           (CFold, s (FOLDleft, FOLDright))
adamc@82:        | UNIT                           (CUnit, s (UNITleft, UNITright))
adamc@1: 
adamc@1: rcon   :                                ([])
adamc@1:        | ident EQ cexp                  ([(ident, cexp)])
adamc@1:        | ident EQ cexp COMMA rcon       ((ident, cexp) :: rcon)
adamc@1: 
adamc@83: rconn  : ident                          ([(ident, (CUnit, s (identleft, identright)))])
adamc@83:        | ident COMMA rconn              ((ident, (CUnit, s (identleft, identright))) :: rconn)
adamc@83: 
adamc@1: rcone  :                                ([])
adamc@1:        | ident COLON cexp               ([(ident, cexp)])
adamc@1:        | ident COLON cexp COMMA rcone   ((ident, cexp) :: rcone)
adamc@1: 
adamc@1: ident  : CSYMBOL                        (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
adamc@89:        | path                           (CVar path, s (pathleft, pathright))
adamc@8: 
adamc@8: eapps  : eterm                          (eterm)
adamc@8:        | eapps eterm                    (EApp (eapps, eterm), s (eappsleft, etermright))
adamc@8:        | eapps LBRACK cexp RBRACK       (ECApp (eapps, cexp), s (eappsleft, RBRACKright))
adamc@8: 
adamc@8: eexp   : eapps                          (eapps)
adamc@8:        | FN SYMBOL kcolon kind DARROW eexp (ECAbs (kcolon, SYMBOL, kind, eexp), s (FNleft, eexpright))
adamc@8:        | FN SYMBOL COLON cexp DARROW eexp (EAbs (SYMBOL, SOME cexp, eexp), s (FNleft, eexpright))
adamc@8:        | FN SYMBOL DARROW eexp          (EAbs (SYMBOL, NONE, eexp), s (FNleft, eexpright))
adamc@93:        | LBRACK cterm TWIDDLE cterm RBRACK DARROW eexp(EDisjoint (cterm1, cterm2, eexp), s (LBRACKleft, RBRACKright))
adamc@93:        | FN UNIT DARROW eexp            (let
adamc@93:                                              val loc = s (FNleft, eexpright)
adamc@93:                                          in
adamc@93:                                              (EAbs ("_", SOME (TRecord (CRecord [], loc), loc), eexp), loc)
adamc@93:                                          end)
adamc@8: 
adamc@8:        | LPAREN eexp RPAREN DCOLON cexp (EAnnot (eexp, cexp), s (LPARENleft, cexpright))
adamc@149:        | eexp MINUSMINUS cexp           (ECut (eexp, cexp), s (eexpleft, cexpright))
adamc@170:        | CASE eexp OF barOpt branch branchs (ECase (eexp, branch :: branchs), s (CASEleft, branchsright))
adamc@8: 
adamc@8: eterm  : LPAREN eexp RPAREN             (#1 eexp, s (LPARENleft, RPARENright))
adamc@8: 
adamc@34:        | path                           (EVar path, s (pathleft, pathright))
adamc@156:        | cpath                          (EVar cpath, s (cpathleft, cpathright))
adamc@12:        | LBRACE rexp RBRACE             (ERecord rexp, s (LBRACEleft, RBRACEright))
adamc@110:        | UNIT                           (ERecord [], s (UNITleft, UNITright))
adamc@12: 
adamc@14:        | INT                            (EPrim (Prim.Int INT), s (INTleft, INTright))
adamc@14:        | FLOAT                          (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
adamc@14:        | STRING                         (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
adamc@14: 
adamc@142:        | path DOT ident                 (EField ((EVar path, s (pathleft, pathright)), ident), s (pathleft, identright))
adamc@71:        | FOLD                           (EFold, s (FOLDleft, FOLDright))
adamc@71: 
adamc@91:        | XML_BEGIN xml XML_END          (xml)
adamc@91:        | XML_BEGIN XML_END              (EApp ((EVar (["Basis"], "cdata"), s (XML_BEGINleft, XML_ENDright)),
adamc@91:                                                (EPrim (Prim.String ""), s (XML_BEGINleft, XML_ENDright))),
adamc@91:                                          s (XML_BEGINleft, XML_ENDright))
adamc@91: 
adamc@170: branch : pat DARROW eexp                (pat, eexp)
adamc@170: 
adamc@170: branchs:                                ([])
adamc@170:        | BAR branch branchs             (branch :: branchs)
adamc@170: 
adamc@170: pat    : pterm                          (pterm)
adamc@170:        | cpath pterm                    (PCon (#1 cpath, #2 cpath, SOME pterm), s (cpathleft, ptermright))
adamc@170: 
adamc@170: pterm  : SYMBOL                         (PVar SYMBOL, s (SYMBOLleft, SYMBOLright))
adamc@170:        | cpath                          (PCon (#1 cpath, #2 cpath, NONE), s (cpathleft, cpathright))
adamc@170:        | UNDER                          (PWild, s (UNDERleft, UNDERright))
adamc@173:        | INT                            (PPrim (Prim.Int INT), s (INTleft, INTright))
adamc@173:        | STRING                         (PPrim (Prim.String STRING), s (STRINGleft, STRINGright))
adamc@170:        | LPAREN pat RPAREN              (pat)
adamc@174:        | LBRACE RBRACE                  (PRecord ([], false), s (LBRACEleft, RBRACEright))
adamc@174:        | UNIT                           (PRecord ([], false), s (UNITleft, UNITright))
adamc@174:        | LBRACE rpat RBRACE             (PRecord rpat, s (LBRACEleft, RBRACEright))
adamc@174: 
adamc@175: rpat   : CSYMBOL EQ pat                 ([(CSYMBOL, pat)], false)
adamc@174:        | DOTDOTDOT                      ([], true)
adamc@175:        | CSYMBOL EQ pat COMMA rpat      ((CSYMBOL, pat) :: #1 rpat, #2 rpat)
adamc@170: 
adamc@12: rexp   :                                ([])
adamc@12:        | ident EQ eexp                  ([(ident, eexp)])
adamc@12:        | ident EQ eexp COMMA rexp       ((ident, eexp) :: rexp)
adamc@91: 
adamc@141: xml    : xmlOne xml                     (let
adamc@141:                                              val pos = s (xmlOneleft, xmlright)
adamc@141:                                          in
adamc@141:                                              (EApp ((EApp (
adamc@141:                                                      (EVar (["Basis"], "join"), pos),
adamc@91:                                                   xmlOne), pos),
adamc@141:                                                     xml), pos)
adamc@141:                                          end)
adamc@141:        | xmlOne                         (xmlOne)
adamc@91: 
adamc@141: xmlOne : NOTAGS                         (EApp ((EVar (["Basis"], "cdata"), s (NOTAGSleft, NOTAGSright)),
adamc@141:                                                (EPrim (Prim.String NOTAGS), s (NOTAGSleft, NOTAGSright))),
adamc@141:                                          s (NOTAGSleft, NOTAGSright))
adamc@141:        | tag DIVIDE GT                  (let
adamc@141:                                              val pos = s (tagleft, GTright)
adamc@141:                                          in
adamc@141:                                              (EApp (#2 tag,
adamc@141:                                                     (EApp ((EVar (["Basis"], "cdata"), pos),
adamc@141:                                                            (EPrim (Prim.String ""), pos)),
adamc@141:                                                      pos)), pos)
adamc@141:                                          end)
adamc@141:          
adamc@141:        | tag GT xml END_TAG             (let
adamc@141:                                              val pos = s (tagleft, GTright)
adamc@141:                                          in
adamc@141:                                              if #1 tag = END_TAG then
adamc@141:                                                  if END_TAG = "lform" then
adamc@141:                                                      (EApp ((EVar (["Basis"], "lform"), pos),
adamc@141:                                                             xml), pos)
adamc@141:                                                  else
adamc@141:                                                      (EApp (#2 tag, xml), pos)
adamc@141:                                              else
adamc@141:                                                  (ErrorMsg.errorAt pos "Begin and end tags don't match.";
adamc@141:                                                   (EFold, pos))
adamc@141:                                          end)
adamc@141:        | LBRACE eexp RBRACE             (eexp)
adamc@92: 
adamc@141: tag    : tagHead attrs                  (let
adamc@141:                                              val pos = s (tagHeadleft, attrsright)
adamc@141:                                          in
adamc@141:                                              (#1 tagHead,
adamc@141:                                               (EApp ((EApp ((EVar (["Basis"], "tag"), pos),
adamc@141:                                                             (ERecord attrs, pos)), pos),
adamc@141:                                                      (EApp (#2 tagHead,
adamc@141:                                                             (ERecord [], pos)), pos)),
adamc@141:                                                pos))
adamc@141:                                          end)
adamc@141: 
adamc@141: tagHead: BEGIN_TAG                      (let
adamc@141:                                              val pos = s (BEGIN_TAGleft, BEGIN_TAGright)
adamc@141:                                          in
adamc@141:                                              (BEGIN_TAG,
adamc@141:                                               (EVar ([], BEGIN_TAG), pos))
adamc@141:                                          end)
adamc@141:        | tagHead LBRACE cexp RBRACE     (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
adamc@92:                                           
adamc@104: attrs  :                                ([])
adamc@104:        | attr attrs                     (attr :: attrs)
adamc@104: 
adamc@104: attr   : SYMBOL EQ attrv                ((CName (uppercaseFirst SYMBOL), s (SYMBOLleft, SYMBOLright)), attrv)
adamc@104: 
adamc@104: attrv  : INT                            (EPrim (Prim.Int INT), s (INTleft, INTright))
adamc@104:        | FLOAT                          (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
adamc@104:        | STRING                         (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
adamc@110:        | LBRACE eexp RBRACE             (eexp)