Parser.grm

fun makeUnaryFunction (name,constr) = (name, Syntax.Func (["x"], constr (Syntax.ID ("x"))))

fun makeBinaryFunction (name,constr) = (name, Syntax.Func (["x","y"], constr (Syntax.ID ("x"), Syntax.ID ("y"))))

(* Define the predefined functions *)
val predef = List.map makeUnaryFunction
        [("-", Syntax.UMINUS),
         ("d", Syntax.D),
         ("z", Syntax.Z),
         ("sum", Syntax.SUM),
         ("sign", Syntax.SIGN),
         ("count", Syntax.COUNT),
         ("min",fn (e) => Syntax.LEAST (Syntax.NUM (1), e)),
         ("max",fn (e) => Syntax.LARGEST (Syntax.NUM (1), e)),
         ("minimal", Syntax.MINIMAL),
         ("maximal", Syntax.MAXIMAL),
         ("choose", Syntax.CHOOSE),
         ("different", Syntax.DIFFERENT) ]
      @
      List.map makeBinaryFunction
        [("+", Syntax.PLUS),
         ("*", Syntax.TIMES),
         ("U", Syntax.CONC)]

%%

%name troll_parser

%pos int

%start Dice

%verbose

%noshift EOF
%eop EOF

%term NUM of int
    | ID of string
    | STRINGS of string list
    | D
    | Z
    | SUM
    | LEAST
    | LARGEST
    | MIN
    | MAX
    | CONC
    | HASH
    | COUNT
    | AND
    | PLUS
    | MINUS
    | TIMES
    | DIVIDE
    | MOD
    | LPAR
    | RPAR
    | LBRACE
    | RBRACE
    | COMMA
    | ASSGN
    | EQ
    | NEQ
    | LT
    | GT
    | LE
    | GE
    | DOTDOT
    | SEMI
    | LET
    | IN
    | FOREACH
    | DO
    | IF
    | THEN
    | ELSE
    | CHOOSE
    | DROP
    | KEEP
    | PICK
    | DIFFERENT
    | MEDIAN
    | ACCUM
    | REPEAT
    | WHILE
    | UNTIL 
    | FUNCTION
    | CALL
    | COMPOSITIONAL
    | EOF
    | SAMPLE
    | HCONC
    | VCONCL
    | VCONCR
    | VCONCC
    | UMINUS
    | QUESTION
    | MINIMAL
    | MAXIMAL
    | SETMINUS
    | LBRACK
    | RBRACK
    | FIRST
    | SECOND
    | SIGN
    | TILDE
    | BANG
    | REAL of real

%nonterm Dice of Syntax.Program
       | Decl of (string * Syntax.Declaration)
       | Decls of ((string * Syntax.Declaration) list)
       | Exp of Syntax.Exp
       | ExpNoUn of Syntax.Exp
       | ExpList of Syntax.Exp
       | ExpList1 of Syntax.Exp
       | ExpList2 of Syntax.Exp list
       | Ids of string list
       | IDorUnop of string
       | IDorBinop of string

%nonassoc FUNCTION
%right SEMI
%nonassoc DO ELSE WHILE UNTIL
%right VCONCL VCONCR VCONCC HCONC
%nonassoc DOTDOT
%left DROP KEEP PICK SETMINUS
%right CONC AND
%left PLUS MINUS
%left TIMES DIVIDE MOD
%nonassoc UMINUS
%nonassoc SUM COUNT LEAST LARGEST MIN MAX CHOOSE DIFFERENT SAMPLE MINIMAL MAXIMAL MEDIAN FIRST SECOND SIGN BANG
%right NEQ EQ LT GT LE GE
%right HASH TILDE
%left D Z

%%

Dice : Decls Exp Decls (Decls1 @ Decls2 @ predef, Exp)

Decls : Decl Decls (Decl :: Decls)
      | ([])

Decl : FUNCTION ID LPAR Ids RPAR EQ Exp %prec FUNCTION               (ID, Syntax.Func (Ids, Exp))
     | COMPOSITIONAL ID LPAR Exp COMMA IDorUnop COMMA IDorBinop RPAR (ID, Syntax.Comp (Exp, IDorUnop, IDorBinop))

IDorUnop : ID        (ID)
         | MINUS     ("-")
         | D         ("d")
         | Z         ("z")
         | SUM       ("sum")
         | SIGN      ("sgn")
         | COUNT     ("count")
         | MIN       ("min")
         | MAX       ("max")
         | MINIMAL   ("minimal")
         | MAXIMAL   ("maximal")
         | CHOOSE    ("choose")
         | DIFFERENT ("different")

IDorBinop : ID     (ID)
          | PLUS   ("+")
          | TIMES  ("*")
          | CONC   ("U")

Ids : ID           ([ID])
    | ID COMMA Ids (ID::Ids)

Exp : NUM                           (Syntax.NUM NUM)
    | ID                            (Syntax.ID ID)
    | Exp CONC Exp                  (Syntax.CONC (Exp1, Exp2))
    | CHOOSE Exp                    (Syntax.CHOOSE (Exp))
    | DIFFERENT Exp                 (Syntax.DIFFERENT (Exp))
    | LBRACE ExpList RBRACE         (ExpList)
    | Exp PLUS Exp                  (Syntax.PLUS (Exp1, Exp2))
    | Exp MINUS Exp                 (Syntax.MINUS (Exp1, Exp2))
    | Exp TIMES Exp                 (Syntax.TIMES (Exp1, Exp2))
    | Exp DIVIDE Exp                (Syntax.DIVIDE (Exp1, Exp2))
    | Exp MOD Exp                   (Syntax.MOD (Exp1, Exp2))
    | SUM Exp                       (Syntax.SUM (Exp))
    | SIGN Exp                      (Syntax.SIGN (Exp))
    | COUNT Exp                     (Syntax.COUNT (Exp))
    | MIN Exp                       (Syntax.LEAST (Syntax.NUM (1), Exp))
    | MAX Exp                       (Syntax.LARGEST (Syntax.NUM (1), Exp))
    | MEDIAN Exp                    (Syntax.MEDIAN (Exp))
    | MINIMAL Exp                   (Syntax.MINIMAL (Exp))
    | MAXIMAL Exp                   (Syntax.MAXIMAL (Exp))
    | Exp HASH Exp                  (Syntax.HASH (Exp1, Exp2))
    | Exp AND Exp                   (Syntax.AND (Exp1, Exp2))
    | D Exp                         (Syntax.D (Exp))
    | Exp Z Exp %prec HASH          (Syntax.HASH (Exp1,Syntax.Z (Exp2)))
    | Exp D Exp %prec HASH          (Syntax.HASH (Exp1,Syntax.D (Exp2)))
    | Exp EQ Exp                    (Syntax.EQ (Exp1, Exp2))
    | Exp NEQ Exp                   (Syntax.NEQ (Exp1, Exp2))
    | Exp LT Exp                    (Syntax.LT (Exp1, Exp2))
    | Exp GT Exp                    (Syntax.GT (Exp1, Exp2))
    | Exp LE Exp                    (Syntax.LE (Exp1, Exp2))
    | Exp GE Exp                    (Syntax.GE (Exp1, Exp2))
    | Exp DROP Exp                  (Syntax.DROP (Exp1, Exp2))
    | Exp KEEP Exp                  (Syntax.KEEP (Exp1, Exp2))
    | Exp PICK Exp                  (Syntax.PICK (Exp1, Exp2))
    | Exp SETMINUS Exp              (Syntax.SETMINUS (Exp1, Exp2))
    | Exp DOTDOT Exp                (Syntax.FROMTO (Exp1,Exp2))
    | ID ASSGN Exp SEMI Exp         (Syntax.LET (ID, Exp1, Exp2))
    | ACCUM ID ASSGN Exp WHILE Exp  (Syntax.ACCUM (ID, Exp1, Exp2, true))
    | ACCUM ID ASSGN Exp UNTIL Exp  (Syntax.ACCUM (ID, Exp1, Exp2, false))
    | REPEAT ID ASSGN Exp WHILE Exp (Syntax.REPEAT (ID, Exp1, Exp2, true))
    | REPEAT ID ASSGN Exp UNTIL Exp (Syntax.REPEAT (ID, Exp1, Exp2, false))
    | FOREACH ID IN Exp DO Exp      (Syntax.FOREACH (ID, Exp1, Exp2) )
    | IF Exp THEN Exp ELSE Exp      (Syntax.IF (Exp1, Exp2, Exp3))
    | CALL ID LPAR ExpList2 RPAR    (Syntax.CALL (ID, ExpList2))
    | Exp SAMPLE Exp %prec HASH     (Syntax.SAMPLES (Exp1, Exp2))
    | Exp HCONC Exp                 (Syntax.HCONC (Exp1, Exp2))
    | Exp VCONCL Exp                (Syntax.VCONCL (Exp1, Exp2))
    | Exp VCONCR Exp                (Syntax.VCONCR (Exp1, Exp2))
    | Exp VCONCC Exp                (Syntax.VCONCC (Exp1, Exp2))
    | QUESTION REAL                 (Syntax.QUESTION (REAL))
    | FIRST Exp                     (Syntax.FIRST (Exp))
    | SECOND Exp                    (Syntax.SECOND (Exp))
    | LBRACK Exp COMMA Exp RBRACK   (Syntax.PAIR (Exp1, Exp2))
    | BANG Exp                      (Syntax.IF (Exp, Syntax.EMPTY, Syntax.NUM (1)))
    | ID TILDE Exp                  (Syntax.DEFAULT (ID, Exp))
    | LPAR Exp RPAR                 (Exp)
    | MINUS Exp %prec UMINUS        (Syntax.UMINUS (Exp))
    | Z Exp                         (Syntax.Z (Exp))
    | SAMPLE Exp                    (Syntax.SAMPLE (Exp))
    | LEAST ExpNoUn  Exp            (Syntax.LEAST (ExpNoUn, Exp))
    | LEAST MINUS ExpNoUn  Exp      (Syntax.LEAST (Syntax.UMINUS(ExpNoUn), Exp))
    | LEAST SAMPLE ExpNoUn  Exp     (Syntax.LEAST (Syntax.SAMPLE(ExpNoUn), Exp))
    | LEAST D ExpNoUn  Exp          (Syntax.LEAST (Syntax.D(ExpNoUn), Exp))
    | LEAST Z ExpNoUn  Exp          (Syntax.LEAST (Syntax.Z(ExpNoUn), Exp))
    | LARGEST ExpNoUn  Exp          (Syntax.LARGEST (ExpNoUn,Exp))
    | LARGEST MINUS ExpNoUn  Exp    (Syntax.LARGEST (Syntax.UMINUS(ExpNoUn), Exp))
    | LARGEST SAMPLE ExpNoUn  Exp   (Syntax.LARGEST (Syntax.SAMPLE(ExpNoUn), Exp))
    | LARGEST Z ExpNoUn  Exp        (Syntax.LARGEST (Syntax.Z(ExpNoUn), Exp))
    | LARGEST D ExpNoUn  Exp        (Syntax.LARGEST (Syntax.D(ExpNoUn), Exp))
    | STRINGS                       (let fun build [] = Syntax.STRING ("")
                                           | build [s] = Syntax.STRING (s)
                                           | build ("|>" :: ss) = Syntax.VCONCL(Syntax.STRING (""), build ss)
                                           | build ("<|" :: ss) = Syntax.VCONCR(Syntax.STRING (""), build ss)
                                           | build ("<>" :: ss) = Syntax.VCONCC(Syntax.STRING (""), build ss)
                                           | build ("||" :: ss) = Syntax.HCONC(Syntax.STRING (""), build ss)
                                           | build (s :: "|>" :: ss) = Syntax.VCONCL(Syntax.STRING (s), build ss)
                                           | build (s :: "<|" :: ss) = Syntax.VCONCR(Syntax.STRING (s), build ss)
                                           | build (s :: "<>" :: ss) = Syntax.VCONCC(Syntax.STRING (s), build ss)
                                           | build (s :: "||" :: ss) = Syntax.HCONC(Syntax.STRING (s), build ss)
                                           | build (s :: ss) = Syntax.HCONC(Syntax.STRING (s), build ss)
                                     in
                                       build (STRINGS)
                                     end)

ExpNoUn : NUM                                   (Syntax.NUM NUM)
        | ID                                    (Syntax.ID ID)
        | ExpNoUn CONC ExpNoUn                  (Syntax.CONC (ExpNoUn1, ExpNoUn2))
        | CHOOSE ExpNoUn                        (Syntax.CHOOSE (ExpNoUn))
        | DIFFERENT ExpNoUn                     (Syntax.DIFFERENT (ExpNoUn))
        | LBRACE ExpList RBRACE                 (ExpList)
        | ExpNoUn PLUS ExpNoUn                  (Syntax.PLUS (ExpNoUn1, ExpNoUn2))
        | ExpNoUn TIMES ExpNoUn                 (Syntax.TIMES (ExpNoUn1, ExpNoUn2))
        | ExpNoUn DIVIDE ExpNoUn                (Syntax.DIVIDE (ExpNoUn1, ExpNoUn2))
        | ExpNoUn MOD ExpNoUn                   (Syntax.MOD (ExpNoUn1, ExpNoUn2))
        | SUM ExpNoUn                           (Syntax.SUM (ExpNoUn))
        | SIGN ExpNoUn                          (Syntax.SIGN (ExpNoUn))
        | COUNT ExpNoUn                         (Syntax.COUNT (ExpNoUn))
        | MIN ExpNoUn                           (Syntax.LEAST (Syntax.NUM (1), ExpNoUn))
        | MAX ExpNoUn                           (Syntax.LARGEST (Syntax.NUM (1), ExpNoUn))
        | MEDIAN ExpNoUn                        (Syntax.MEDIAN (ExpNoUn))
        | MINIMAL ExpNoUn                       (Syntax.MINIMAL (ExpNoUn))
        | MAXIMAL ExpNoUn                       (Syntax.MAXIMAL (ExpNoUn))
        | ExpNoUn HASH ExpNoUn                  (Syntax.HASH (ExpNoUn1, ExpNoUn2)) 
        | ExpNoUn AND ExpNoUn                   (Syntax.AND (ExpNoUn1, ExpNoUn2))
        | ExpNoUn EQ ExpNoUn                    (Syntax.EQ (ExpNoUn1, ExpNoUn2))
        | ExpNoUn NEQ ExpNoUn                   (Syntax.NEQ (ExpNoUn1, ExpNoUn2))
        | ExpNoUn LT ExpNoUn                    (Syntax.LT (ExpNoUn1, ExpNoUn2))
        | ExpNoUn GT ExpNoUn                    (Syntax.GT (ExpNoUn1, ExpNoUn2))
        | ExpNoUn LE ExpNoUn                    (Syntax.LE (ExpNoUn1, ExpNoUn2))
        | ExpNoUn GE ExpNoUn                    (Syntax.GE (ExpNoUn1, ExpNoUn2))
        | ExpNoUn DROP ExpNoUn                  (Syntax.DROP (ExpNoUn1, ExpNoUn2))
        | ExpNoUn KEEP ExpNoUn                  (Syntax.KEEP (ExpNoUn1, ExpNoUn2))
        | ExpNoUn PICK ExpNoUn                  (Syntax.PICK (ExpNoUn1, ExpNoUn2))
        | ExpNoUn SETMINUS Exp                  (Syntax.SETMINUS (ExpNoUn, Exp))
        | ExpNoUn DOTDOT Exp                    (Syntax.FROMTO (ExpNoUn, Exp))
        | ID ASSGN ExpNoUn SEMI ExpNoUn         (Syntax.LET (ID, ExpNoUn1, ExpNoUn2))
        | ACCUM ID ASSGN ExpNoUn WHILE ExpNoUn  (Syntax.ACCUM (ID, ExpNoUn1, ExpNoUn2, true))
        | ACCUM ID ASSGN ExpNoUn UNTIL ExpNoUn  (Syntax.ACCUM (ID, ExpNoUn1, ExpNoUn2, false))
        | REPEAT ID ASSGN ExpNoUn WHILE ExpNoUn (Syntax.REPEAT (ID, ExpNoUn1, ExpNoUn2, true))
        | REPEAT ID ASSGN ExpNoUn UNTIL ExpNoUn (Syntax.REPEAT (ID, ExpNoUn1, ExpNoUn2, false))
        | FOREACH ID IN ExpNoUn DO ExpNoUn      (Syntax.FOREACH (ID, ExpNoUn1, ExpNoUn2))
        | IF ExpNoUn THEN ExpNoUn ELSE ExpNoUn  (Syntax.IF (ExpNoUn1, ExpNoUn2, ExpNoUn3))
        | CALL ID LPAR ExpList2 RPAR            (Syntax.CALL (ID, ExpList2))
        | ExpNoUn HCONC ExpNoUn                 (Syntax.HCONC (ExpNoUn1,ExpNoUn2))
        | ExpNoUn VCONCL ExpNoUn                (Syntax.VCONCL (ExpNoUn1,ExpNoUn2))
        | ExpNoUn VCONCR ExpNoUn                (Syntax.VCONCR (ExpNoUn1,ExpNoUn2))
        | ExpNoUn VCONCC ExpNoUn                (Syntax.VCONCC (ExpNoUn1,ExpNoUn2))
        | QUESTION REAL                         (Syntax.QUESTION (REAL))
        | FIRST ExpNoUn                         (Syntax.FIRST (ExpNoUn))
        | SECOND ExpNoUn                        (Syntax.SECOND (ExpNoUn))
        | LBRACK ExpNoUn COMMA ExpNoUn RBRACK   (Syntax.PAIR (ExpNoUn1, ExpNoUn2))
        | BANG ExpNoUn                          (Syntax.IF (ExpNoUn, Syntax.EMPTY, Syntax.NUM (1)))
        | ID TILDE ExpNoUn                      (Syntax.DEFAULT (ID, ExpNoUn))
        | LPAR Exp RPAR                         (Exp)
        | LEAST ExpNoUn  Exp                    (Syntax.LEAST (ExpNoUn, Exp))
        | LEAST MINUS ExpNoUn  Exp              (Syntax.LEAST (ExpNoUn, Exp))
        | LEAST SAMPLE ExpNoUn  Exp             (Syntax.LEAST (ExpNoUn, Exp))
        | LEAST D ExpNoUn  Exp                  (Syntax.LEAST (ExpNoUn, Exp))
        | LEAST Z ExpNoUn  Exp                  (Syntax.LEAST (ExpNoUn, Exp))
        | LARGEST ExpNoUn  Exp                  (Syntax.LARGEST (ExpNoUn, Exp))
        | LARGEST MINUS ExpNoUn  Exp            (Syntax.LARGEST (ExpNoUn,Exp))
        | LARGEST SAMPLE ExpNoUn  Exp           (Syntax.LARGEST (ExpNoUn, Exp))
        | LARGEST Z ExpNoUn  Exp                (Syntax.LARGEST (ExpNoUn, Exp))
        | LARGEST D ExpNoUn  Exp                (Syntax.LARGEST (ExpNoUn, Exp))
        | STRINGS                               (let fun build [] = Syntax.STRING ("")
                                                       | build [s] = Syntax.STRING (s)
                                                       | build ("|>" :: ss) = Syntax.VCONCL(Syntax.STRING (""), build ss)
                                                       | build ("<|" :: ss) = Syntax.VCONCR(Syntax.STRING (""), build ss)
                                                       | build ("<>" :: ss) = Syntax.VCONCC(Syntax.STRING (""), build ss)
                                                       | build ("||" :: ss) = Syntax.HCONC(Syntax.STRING (""), build ss)
                                                       | build (s :: "|>" :: ss) = Syntax.VCONCL(Syntax.STRING (s), build ss)
                                                       | build (s :: "<|" :: ss) = Syntax.VCONCR(Syntax.STRING (s), build ss)
                                                       | build (s :: "<>" :: ss) = Syntax.VCONCC(Syntax.STRING (s), build ss)
                                                       | build (s :: "||" :: ss) = Syntax.HCONC(Syntax.STRING (s), build ss)
                                                       | build (s :: ss) = Syntax.HCONC(Syntax.STRING (s), build ss)
                                                        in
                                                          build (STRINGS)
                                                        end)

ExpList :          (Syntax.EMPTY)
        | ExpList1 (ExpList1)

ExpList1 : Exp                (Exp)
         | Exp COMMA ExpList1 (Syntax.CONC (Exp,ExpList1))

ExpList2 : Exp                ([Exp])
         | Exp COMMA ExpList2 (Exp :: ExpList2)