Improve support for infix operators.

2 files changed, 133 insertions, 59 deletions

diff --git a/parser.sml b/parser.sml
index 08cb992..6e82e19 100644
--- a/parser.sml
+++ b/parser.sml
@@ -7,7 +7,7 @@ structure Parser =
 struct
   (* vector of length 10, holding the left and right associative infix operators for each precedence level. *)
   type infixTable = (string list * string list) vector
-  datatype userState = UserState of string list * infixTable
+  datatype userState = UserState of infixTable
   datatype sourceLoc = SourceLoc of string * int * int  (* file * row * column *)
   datatype state = State of TextIO.StreamIO.instream * sourceLoc * userState
   datatype response = Consumed | Empty
@@ -26,19 +26,8 @@ struct
     , "signature", "struct", "structure", "where", ":>"
     ]
 
-  val defaultInfixOperators =
-    Vector.fromList
-      [ (["before"], [])
-      , ([], [])
-      , ([], [])
-      , ([":=", "o"], [])
-      , (["=", "<>", ">", ">=", "<", "<="], [])
-      , (["@@"], ["::", "@"])
-      , (["+", "-", "^"], [])
-      , (["*", "/", "div", "mod"], [])
-      , ([], [])
-      , ([], [])
-      ]
+  val emptyInfixOperators : infixTable =
+    Vector.tabulate (10, fn _ => ([], []))
 
   fun printSourceLoc (SourceLoc (fileName, row, col)) : string =
     fileName ^ ":" ^ Int.toString row ^ "." ^ Int.toString col
@@ -72,11 +61,11 @@ struct
   fun collectInfixOperators (opTable : (string list * string list) vector) : string list =
     Vector.foldl (fn ((a, b), acc) => a @ b @ acc) [] opTable
 
-  fun makeUserState (opTable : infixTable) : userState =
-    UserState (Vector.foldl (fn ((a, b), acc) => a @ b @ acc) [] opTable, opTable)
+  fun infixOps (opTable : infixTable) : string list =
+    Vector.foldl (fn ((a, b), acc) => a @ b @ acc) [] opTable
 
   fun newState (fileName : string) (fileStream : TextIO.instream) : state =
-    State (TextIO.getInstream fileStream, newLoc fileName, makeUserState defaultInfixOperators)
+    State (TextIO.getInstream fileStream, newLoc fileName, UserState emptyInfixOperators)
 
   fun updateUserState (f : userState -> userState) : userState parser =
     fn State (stream, loc, us) =>
@@ -233,7 +222,13 @@ struct
 
   val alphaNumIdentifier : string parser =
     lexeme
-      (bind (letter <|> parseChar #"'") (fn firstLetter =>
+      (bind letter (fn firstLetter =>
+      bind (many alphaNumIdentifierLetter) (fn rest =>
+      const (implode (firstLetter :: rest)))))
+
+  val tyvar : string parser =
+    lexeme
+      (bind (parseChar #"'") (fn firstLetter =>
       bind (many alphaNumIdentifierLetter) (fn rest =>
       const (implode (firstLetter :: rest)))))
 
@@ -241,13 +236,20 @@ struct
     lexeme
       (implode <$> many1 symbolicIdentifierLetter)
 
-  val identifier : string parser =
+  fun notReserved (reserved : string list) : string parser =
     try
       (bind (alphaNumIdentifier <|> symbolicIdentifier <?> "identifier") (fn identName =>
-      bind getUserState (fn UserState (ops, _) =>
-      if List.exists (fn n => n = identName) reservedWords orelse List.exists (fn n => n = identName) ops
+      if List.exists (fn n => n = identName) reserved
       then unexpected identName
-      else const identName)))
+      else const identName))
+
+  val identifier : string parser =
+    bind getUserState (fn UserState st =>
+    notReserved (infixOps st @ reservedWords))
+
+  val tycon : string parser =
+    bind getUserState (fn st =>
+    notReserved ("*" :: reservedWords))
 
   fun sepBy1 (p : 'a parser) (sep : 'b parser) : 'a list parser =
     bind p (fn x =>
@@ -282,6 +284,20 @@ struct
       <?> s
     end
 
+  val infixIdentifier : string parser =
+    bind getUserState (fn UserState infixOps =>
+    let val ops = map reserved (Vector.foldl (fn ((l, r), acc) => l @ r @ acc) [] infixOps)
+    in
+      case ops of
+        [] => unexpected "infix op"
+      | x :: xs => foldl op <|> x xs <?> "infix op"
+    end)
+
+  val longInfixIdentifier : string list parser =
+    bind (many (bind identifier (fn id => symbol "." >> const id))) (fn idents =>
+    bind infixIdentifier (fn ii =>
+    const (idents @ [ii])))
+
   val digit : char parser = satisfy Char.isDigit <?> "digit"
 
   val integer : int parser =
@@ -319,16 +335,16 @@ struct
     const x)
 
   fun parseTycons (ty : Syntax.etype) : Syntax.etype parser =
-        bind identifier (fn longtycon =>
+        bind tycon (fn longtycon =>
         parseTycons (Syntax.Tycon ([ty], longtycon)))
     <|> const ty
 
   val rec parseSingleType : Syntax.etype parser = fn st =>
-      (Syntax.Tyvar <$> identifier
+      (Syntax.Tyvar <$> (tyvar <|> tycon)
   <|> bind (between (symbol "(") (symbol ")") (sepBy1 parseType (symbol ","))) (fn types =>
       case types of
         [x] => const x
-      | _ => bind identifier (fn longtycon =>
+      | _ => bind tycon (fn longtycon =>
              const (Syntax.Tycon (types, longtycon))))) st
   and parseTycon : Syntax.etype parser =
     fn st =>
@@ -348,6 +364,24 @@ struct
           const (Syntax.Tyfun (ty, ty'))))
       <|> const ty) st
 
+  fun leftOp (i : int) : string parser =
+    bind getUserState (fn UserState opTable =>
+    let val (leftOps, _) = Vector.sub (opTable, i)
+    in
+      case (map reserved leftOps) of
+        [] => unexpected "left-associative operator"
+      | op1 :: ops => (fn x => x) <$> foldl op <|> op1 ops
+    end)
+
+  fun rightOp (i : int) : string parser =
+    bind getUserState (fn UserState opTable =>
+    let val (_, rightOps) = Vector.sub (opTable, i)
+    in
+      case (map reserved rightOps) of
+        [] => unexpected "right-associative operator"
+      | op1 :: ops => (fn x => x) <$> foldl op <|> op1 ops
+    end)
+
   val rec atpat : Syntax.pat parser = fn st =>
       (Syntax.PWild <$ reserved "_"
   <|> Syntax.PInt <$> integer
@@ -357,43 +391,47 @@ struct
           [p] => p
         | _ => Syntax.PTuple pats))
   <|> Syntax.PVar <$> identifier) st
-  and pat : Syntax.pat parser = fn st =>
+  and appPat : Syntax.pat parser = fn st =>
       (bind identifier (fn ident =>
           bind atpat (fn arg =>
           const (Syntax.PCon (ident, arg)))
       <|> const (Syntax.PVar ident))
   <|> atpat) st
-
-  fun leftOp (i : int) : Syntax.expr parser =
-    bind getUserState (fn UserState (_, opTable) =>
-    let val (leftOps, _) = Vector.sub (opTable, i)
-    in
-      case (map reserved leftOps) of
-        [] => unexpected "left-associative operator"
-      | op1 :: ops => (fn x => Syntax.EIdent [x]) <$> foldl (op <|>) op1 ops
-    end)
-
-  fun rightOp (i : int) : Syntax.expr parser =
-    bind getUserState (fn UserState (_, opTable) =>
-    let val (_, rightOps) = Vector.sub (opTable, i)
-    in
-      case (map reserved rightOps) of
-        [] => unexpected "right-associative operator"
-      | op1 :: ops => (fn x => Syntax.EIdent [x]) <$> foldl (op <|>) op1 ops
-    end)
+  and pat : Syntax.pat parser = fn st =>
+    foldl
+      (fn (i, patLower) =>
+        let
+          fun patLeft pat1 =
+            bind (leftOp i) (fn opEx =>
+            bind patLower (fn pat2 =>
+            let val app = Syntax.PCon (opEx, Syntax.PTuple [pat1, pat2])
+            in patLeft app <|> const app
+            end))
+          fun patRight pat1 =
+            bind (rightOp i) (fn opEx =>
+            bind patLower (fn pat2 =>
+            bind (patRight pat2 <|> const pat2) (fn rest =>
+            const (Syntax.PCon (opEx, Syntax.PTuple [pat1, rest])))))
+        in
+          bind patLower (fn pat1 =>
+          patLeft pat1 <|> patRight pat1 <|> const pat1)
+        end)
+      appPat
+      (List.tabulate (10, fn i => 9 - i)) st
 
   val rec atom : Syntax.expr parser =
     fn st =>
       (Syntax.EInt <$> integer
       <|> Syntax.EStr <$> stringConstant
       <|> Syntax.EIdent <$> longIdentifier
+      <|> (reserved "op" >> Syntax.EIdent <$> longInfixIdentifier)
       <|> builtin
       <|> (reserved "let" >>
            bind (many dec) (fn decs =>
            reserved "in" >>
            bind expr (fn e =>
            reserved "end" >>
-           const (Syntax.ELet (decs, e)))))
+           const (Syntax.ELet (List.mapPartial (fn x => x) decs, e)))))
       <|> (symbol "(" >>
            bind (sepBy expr (symbol ",")) (fn exprs =>
            symbol ")" >>
@@ -413,14 +451,14 @@ struct
             fun exprLeft expr1 =
               bind (leftOp i) (fn opEx =>
               bind exprLower (fn expr2 =>
-              let val app = Syntax.EApp (opEx, Syntax.ETuple [expr1, expr2])
+              let val app = Syntax.EApp (Syntax.EIdent [opEx], Syntax.ETuple [expr1, expr2])
               in exprLeft app <|> const app
               end))
             fun exprRight expr1 =
               bind (rightOp i) (fn opEx =>
               bind exprLower (fn expr2 =>
               bind (exprRight expr2 <|> const expr2) (fn rest =>
-              const (Syntax.EApp (opEx, Syntax.ETuple [expr1, rest])))))
+              const (Syntax.EApp (Syntax.EIdent [opEx], Syntax.ETuple [expr1, rest])))))
           in
             bind exprLower (fn expr1 =>
             exprLeft expr1 <|> exprRight expr1 <|> const expr1)
@@ -466,44 +504,69 @@ struct
           (reserved "|")) (fn arms =>
       const (Syntax.ECase (e, arms)))))
   <|> orelseExpr) st
-  and dec : Syntax.dec parser = fn st =>
-      ((reserved "datatype" >>
+  and dec : Syntax.dec option parser = fn st =>
+      (bind (false <$ reserved "infix" <|> true <$ reserved "infixr") (fn direction =>
+      bind (integer <|> const 0) (fn level =>
+      bind (many1 identifier) (fn ops =>
+      updateUserState
+        (fn UserState table =>
+          let val (leftOps, rightOps) = Vector.sub (table, level)
+          in
+            if direction
+            then UserState (Vector.update (table, level, (leftOps, ops @ rightOps)))
+            else UserState (Vector.update (table, level, (ops @ leftOps, rightOps)))
+          end) >>
+      const NONE)))
+  <|> (reserved "datatype" >>
+          (between (symbol "(") (symbol ")") (sepBy1 tyvar (symbol ","))
+      <|> (fn x => [x]) <$> tyvar
+      <|> const []) >>
       bind identifier (fn name =>
       reserved "=" >>
       bind
         (sepBy1
-          (bind identifier (fn con =>
+          (bind (infixIdentifier <|> identifier) (fn con =>
               (reserved "of" >>
               bind parseType (fn ty =>
               const (con, SOME ty)))
           <|> const (con, NONE)))
           (reserved "|")) (fn cons =>
-      const (Syntax.DDatatype (name, cons)))))
+      const (SOME (Syntax.DDatatype (name, cons))))))
   <|> (reserved "val" >>
       bind (true <$ reserved "rec" <|> const false) (fn isRec =>
       bind pat (fn p =>
       reserved "=" >>
       bind expr (fn e =>
       const
-        (if isRec
-        then Syntax.DValRec (p, e)
-        else Syntax.DVal (p, e))))))
+        (SOME
+          (if isRec
+          then Syntax.DValRec (p, e)
+          else Syntax.DVal (p, e)))))))
   <|> (reserved "fun" >>
       bind
         (sepBy1
-          (bind identifier (fn name =>
-          bind (many1 atpat) (fn args =>
+          (bind (bind atpat (fn pat1 =>
+              bind infixIdentifier (fn infixOp =>
+              bind atpat (fn pat2 =>
+              const (infixOp, [Syntax.PTuple [pat1, pat2]])))
+          <|> (case pat1 of
+                Syntax.PVar name =>
+                  bind (many1 atpat) (fn args =>
+                  const (name, args))
+              | _ => unexpected "pattern"))) (fn (name, args) =>
           reserved "=" >>
           bind expr (fn body =>
-          const (name, args, body)))))
+          const (name, args, body))))
           (reserved "|")) (fn cases =>
       let val (name, _, _) = hd cases
       in
         if not (List.all (fn (n, _, _) => n = name) cases)
         then raise Fail "clauses do not all have same function name"
-        else const (Syntax.DFun (name, map (fn (_, x, y) => (x, y)) cases))
+        else const (SOME (Syntax.DFun (name, map (fn (_, x, y) => (x, y)) cases)))
       end))) st
 
-  val program : Syntax.expr parser = (fn decs => Syntax.ELet (decs, Syntax.EInt 0)) <$> many dec
+  val program : Syntax.expr parser =
+    bind (many dec) (fn decs =>
+    const (Syntax.ELet (List.mapPartial (fn x => x) decs, Syntax.EInt 0)))
   fun parse (f : string) : (string, Syntax.expr) Result.either = runParser program f
 end
diff --git a/tests/19-list.sml b/tests/19-list.sml
new file mode 100644
index 0000000..52404dc
--- /dev/null
+++ b/tests/19-list.sml
@@ -0,0 +1,11 @@
+infix 6 +
+infixr 5 ::
+
+datatype 'a list = Nil | :: of 'a * 'a list
+
+fun x + y = __builtin "add" (x, y)
+
+fun foldl _ acc Nil = acc
+  | foldl f acc (x :: xs) = foldl f (f (x, acc)) xs
+
+val _ = __builtin "exit" (foldl op + 0 (1 :: 2 :: 3 :: 6 :: 8 :: 10 :: 12 :: Nil))