1 files changed, 672 insertions, 0 deletions
diff --git a/Parser.sml b/Parser.sml
new file mode 100644
index 0000000..e464332
--- /dev/null
+++ b/Parser.sml
@@ -0,0 +1,672 @@
+infix 4 <$> <$
+infix 1 >>
+infixr 1 <|>
+infix 0 <?>
+
+structure Parser =
+struct
+  structure StringMap = Map(type k = string val cmp = String.compare)
+
+  (* vector of length 10, holding the left and right associative infix operators for each precedence level. *)
+  type infixTable = (string list * string list) vector
+  type userState = {infixTable : infixTable}
+  type sourceLoc = {file : string, row : int, column : int}
+  type state = {stream : TextIO.StreamIO.instream, loc : sourceLoc, userState : userState}
+  datatype response = Consumed | Empty
+  datatype message = Unexpected of string | Expected of string
+  type parseError = {loc : sourceLoc, msgs : message list}
+  datatype hints = Hints of string list
+  type 'a parser = state -> response * (parseError, 'a * state * hints) Result.either
+
+  val reservedWords =
+    [ "abstype", "and", "andalso", "as", "case", "datatype", "do", "else"
+    , "end", "exception", "fn", "fun", "handle", "if", "in", "infix"
+    , "infixr", "let", "local", "nonfix", "of", "op", "open", "orelse"
+    , "raise", "rec", "then", "type", "val", "with", "withtype", "while"
+    , "(", ")", "[", "]", "{", "}", ",", ":", ";", "...", "_", "|", "=", "=>", "->", "#"
+    , "eqtype", "functor", "include", "sharing", "sig"
+    , "signature", "struct", "structure", "where", ":>"
+    ]
+
+  val emptyInfixOperators : infixTable =
+    Vector.tabulate (10, fn _ => ([], []))
+
+  fun printSourceLoc ({file, row, column} : sourceLoc) : string =
+    file ^ ":" ^ Int.toString row ^ "." ^ Int.toString column
+
+  fun printError ({loc, msgs} : parseError) : string =
+    let
+      val unexpect = List.mapPartial (fn Unexpected x => SOME x | _ => NONE) msgs
+      val showUnexpect = case unexpect of
+                           [] => ""
+                         | s :: _ => "unexpected " ^ s ^ ";\n"
+      val expect = List.mapPartial (fn Expected s => SOME s | _ => NONE) msgs
+    in
+        printSourceLoc loc ^ " Syntax error:\n"
+      ^ showUnexpect
+      ^ "expecting " ^ String.concatWith ", " expect
+    end
+
+  fun unpackParserResponse (_ : response, Result.Left err : (parseError, 'a * state * hints) Result.either) : (string, 'a) Result.either =
+        Result.Left (printError err)
+    | unpackParserResponse (_, Result.Right (a, st, _)) =
+        if TextIO.StreamIO.endOfStream (#stream st)
+        then Result.Right a
+        else Result.Left (printSourceLoc (#loc st) ^ " Syntax error: trailing characters")
+
+  fun newLoc (fileName : string) : sourceLoc = {
+    file = fileName,
+    row = 1,
+    column = 1
+  }
+
+  fun collectInfixOperators (opTable : (string list * string list) vector) : string list =
+    Vector.foldl (fn ((a, b), acc) => a @ b @ acc) [] 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 = {
+    stream = TextIO.getInstream fileStream,
+    loc = newLoc fileName,
+    userState = {infixTable = emptyInfixOperators}
+  }
+
+  fun updateUserState (f : userState -> userState) : userState parser =
+    fn {stream, loc, userState} =>
+      let val st' = f userState
+      in (Empty, Result.Right (st', {stream = stream, loc = loc, userState = st'}, Hints []))
+      end
+
+  val getUserState : userState parser = updateUserState (fn x => x)
+
+  fun runParser (p : 'a parser) (fileName : string) : (string, 'a) Result.either =
+    unpackParserResponse (p (newState fileName (TextIO.openIn fileName)))
+
+  fun testParser (p : 'a parser) (s : string) : 'a =
+    case unpackParserResponse (p (newState "STRING" (TextIO.openString s))) of
+      Result.Right x => x
+    | Result.Left e => raise Fail ("Parse failed: " ^ e)
+
+  fun mergeHints (Hints a) (Hints b) : hints = Hints (a @ b)
+
+  fun withHints (Hints hints) ({loc, msgs} : parseError) : parseError = {
+    loc = loc,
+    msgs = map Expected hints @ msgs
+  }
+
+  fun errToHints ({msgs, ...} : parseError) : hints = Hints (List.mapPartial (fn Expected s => SOME s | _ => NONE) msgs)
+
+  fun compareLoc (l : sourceLoc, m : sourceLoc) : order =
+    case Int.compare (#row l, #row m) of
+      EQUAL => Int.compare (#column l, #column m)
+    | ord => ord
+
+  fun mergeError (e1 : parseError) (e2 : parseError) : parseError =
+    (* pick the longest match *)
+    case compareLoc (#loc e1, #loc e2) of
+      EQUAL => {
+        loc = #loc e1,
+        msgs = #msgs e1 @ #msgs e2
+      }
+    | GREATER => e1
+    | LESS => e2
+
+  fun bind (p : 'a parser) (f : 'a -> 'b parser) : 'b parser =
+    fn st =>
+      case p st of
+        (consumed1, Result.Right (a, st', hints)) =>
+          (case (f a) st' of
+            (Consumed, Result.Right success) => (Consumed, Result.Right success)
+          | (Empty, Result.Right (b, st'', hints')) => (consumed1, Result.Right (b, st'', mergeHints hints hints'))
+          | (Consumed, Result.Left err) => (Consumed, Result.Left (withHints hints err))
+          | (Empty, Result.Left err) => (consumed1, Result.Left (withHints hints err)))
+      | (consumed, Result.Left err) => (consumed, Result.Left err)
+
+  fun (p1 : 'a parser) >> (p2 : 'b parser) : 'b parser = bind p1 (fn _ => p2)
+
+  fun (p : 'a parser) <?> (msg : string) : 'a parser =
+    fn st =>
+      case p st of
+        (consumed, Result.Right (a, st', _)) => (consumed, Result.Right (a, st', Hints [msg]))
+      | (consumed, Result.Left {loc, ...}) => (consumed, Result.Left {loc = loc, msgs = [Expected msg]})
+
+  fun (p1 : 'a parser) <|> (p2 : 'a parser) : 'a parser =
+    fn st =>
+      case p1 st of
+        (Empty, Result.Left err) =>
+          (case p2 st of
+            (Empty, Result.Right (a, st', hints)) => (Empty, Result.Right (a, st', mergeHints (errToHints err) hints))
+          | (Empty, Result.Left err') => (Empty, Result.Left (mergeError err err'))
+          | res => res)
+      | res => res
+
+  fun const (x : 'a) (st : state) = (Empty, Result.Right (x, st, Hints []))
+
+  fun (f : 'a -> 'b) <$> (p : 'a parser) : 'b parser = bind p (const o f)
+
+  fun (x : 'a) <$ (p : 'b parser) : 'a parser = (fn _ => x) <$> p
+
+  fun try (p : 'a parser) : 'a parser =
+    fn st =>
+      case p st of
+        (Consumed, Result.Left err) => (Empty, Result.Left err)
+      | res => res
+
+  fun updatePosChar ({file, row, column} : sourceLoc) (c : char) : sourceLoc =
+    case c of
+      #"\n" => {
+        file = file,
+        row = row + 1,
+        column = 1
+      }
+    | #"\t" => {
+      file = file,
+      row = row,
+      column = column + 8 - (column - 1) mod 8
+    }
+    | _ => {
+      file = file,
+      row = row,
+      column = column + 1
+    }
+
+  fun satisfy (pred : char -> bool) : char parser =
+    fn {stream, loc, userState} =>
+      case TextIO.StreamIO.input1 stream of
+        NONE => (Empty, Result.Left {loc = loc, msgs = [Expected "UNKNOWN"]})
+      | SOME (c, stream') =>
+          if pred c
+          then (Consumed, Result.Right (c, {stream = stream', loc = updatePosChar loc c, userState = userState}, Hints []))
+          else (Empty, Result.Left {loc = loc, msgs = [Expected "UNKNOWN"]})
+
+  fun parseChar (c : char) : char parser =
+    satisfy (fn c' => c = c') <?> str c
+
+  fun parseString (s : string) : string parser =
+    case explode s of
+      [] => const ""
+    | c1 :: cs => s <$ foldl (fn (c, p) => p >> parseChar c) (parseChar c1) cs <?> "'" ^ String.toString s ^ "'"
+
+  fun manyErr () = raise Fail "many is applied to a parser that accepts an empty string"
+
+  fun many (p : 'a parser) : 'a list parser =
+    fn st =>
+      let fun walk xs s' =
+            case p s' of
+              (Consumed, Result.Right (x, s'', _)) => walk (x :: xs) s''
+            | (Consumed, Result.Left err) => (Consumed, Result.Left err)
+            | (Empty, Result.Right _) => manyErr ()
+            | (Empty, Result.Left err) => (Consumed, Result.Right (rev xs, s', errToHints err))
+      in
+        case p st of
+          (Consumed, Result.Right (x, s', _)) => walk [x] s'
+        | (Consumed, Result.Left err) => (Consumed, Result.Left err)
+        | (Empty, Result.Right _) => manyErr ()
+        | (Empty, Result.Left err) => (Empty, Result.Right ([], st, errToHints err))
+      end
+
+  fun many1 (p : 'a parser) : 'a list parser =
+    bind p (fn x =>
+    bind (many p) (fn xs =>
+    const (x :: xs)))
+
+  val space : char parser = satisfy Char.isSpace <?> "space"
+
+  val spaces : unit parser = () <$ many space <?> "white space"
+
+  fun unexpected (s : string) : 'a parser =
+    fn {loc, ...} => (Empty, Result.Left {loc = loc, msgs = [Unexpected s]})
+
+  val letter : char parser = satisfy Char.isAlpha <?> "letter"
+
+  val alphaNum : char parser = satisfy Char.isAlphaNum <?> "letter or digit"
+
+  fun oneOf ([] : char list) : char parser = raise Fail "oneOf empty"
+    | oneOf (x :: xs) = foldl (fn (c, p) => p <|> parseChar c) (parseChar x) xs
+
+  (* some day, whiteSpace will support comments *)
+  val whiteSpace = spaces
+
+  fun lexeme (p : 'a parser) : 'a parser =
+    bind p (fn x =>
+    whiteSpace >>
+    const x)
+
+  val alphaNumIdentifierLetter : char parser =
+    alphaNum <|> oneOf [#"'", #"_"]
+
+  val symbolicIdentifierLetters : char list =
+    [ #"!", #"%", #"&", #"$", #"#", #"+", #"-", #"/", #":", #"<"
+    , #"=", #">", #"?", #"@", #"\\", #"~", #"`", #"^", #"|", #"*"
+    ]
+
+  val symbolicIdentifierLetter : char parser = oneOf symbolicIdentifierLetters
+
+  val alphaNumIdentifier : string parser =
+    lexeme
+      (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)))))
+
+  val symbolicIdentifier : string parser =
+    lexeme
+      (implode <$> many1 symbolicIdentifierLetter)
+
+  fun notReserved (reserved : string list) : string parser =
+    try
+      (bind (alphaNumIdentifier <|> symbolicIdentifier <?> "identifier") (fn identName =>
+      if List.exists (fn n => n = identName) reserved
+      then unexpected identName
+      else const identName))
+
+  val identifier : string parser =
+    bind getUserState (fn {infixTable, ...} =>
+    notReserved (infixOps infixTable @ 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 =>
+    bind (many (sep >> p)) (fn xs =>
+    const (x :: xs)))
+
+  fun sepBy (p : 'a parser) (sep : 'b parser) : 'a list parser =
+    sepBy1 p sep <|> const []
+
+  fun symbol (s : string) : string parser = lexeme (parseString s)
+
+  val longIdentifier : string list parser = sepBy1 identifier (symbol ".")
+
+  fun notFollowedBy (p : char parser) : unit parser =
+    bind (try p) (fn c => unexpected (str c))
+    <|> const ()
+
+  fun reserved (s : string) : string parser =
+    let
+      val start =
+        if s = ""
+        then raise Fail "reserved was called on an empty string"
+        else String.sub (s, 0)
+      val isSymbolic =
+        List.exists (fn c => c = start) symbolicIdentifierLetters
+    in
+      lexeme
+        (try
+          (parseString s >>
+          notFollowedBy (if isSymbolic then symbolicIdentifierLetter else alphaNumIdentifierLetter) >>
+          const s))
+      <?> s
+    end
+
+  val infixIdentifier : string parser =
+    bind getUserState (fn {infixTable, ...} =>
+    let val ops = map reserved (Vector.foldl (fn ((l, r), acc) => l @ r @ acc) [] infixTable)
+    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 =
+    lexeme
+      (bind (many1 digit) (fn digits =>
+      const (valOf (Int.fromString (implode digits)))))
+
+  val stringInternalChar : char parser =
+    (parseString "\\" >> (#"\a" <$ parseChar #"a"
+                         <|> #"\b" <$ parseChar #"b"
+                         <|> #"\t" <$ parseChar #"t"
+                         <|> #"\n" <$ parseChar #"n"
+                         <|> #"\v" <$ parseChar #"v"
+                         <|> #"\f" <$ parseChar #"f"
+                         <|> #"\r" <$ parseChar #"r"
+                         <|> parseChar #"\""
+                         <|> parseChar #"\\") <?> "string escape")
+    <|> (satisfy (fn c => c <> #"\"" andalso c <> #"\\") <?> "string character")
+
+  val stringConstant : string parser =
+    lexeme
+      (parseString "\"" >>
+      bind (implode <$> many stringInternalChar) (fn stringContent =>
+      parseString "\"" >>
+      const stringContent))
+
+  val builtin : Syntax.expr parser =
+    reserved "__builtin" >>
+    Syntax.EBuiltin <$> stringConstant
+
+  fun between (left : 'a parser) (right : 'b parser) (p : 'c parser) : 'c parser =
+    left >>
+    bind p (fn x =>
+    right >>
+    const x)
+
+  fun parseTycons (ty : Syntax.etype) : Syntax.etype parser =
+        bind tycon (fn longtycon =>
+        parseTycons (Syntax.Tycon ([ty], longtycon)))
+    <|> const ty
+
+  val rec parseSingleType : Syntax.etype parser = fn st =>
+      (Syntax.Tyvar <$> (tyvar <|> tycon)
+  <|> bind (between (symbol "(") (symbol ")") (sepBy1 parseType (symbol ","))) (fn types =>
+      case types of
+        [x] => const x
+      | _ => bind tycon (fn longtycon =>
+             const (Syntax.Tycon (types, longtycon))))) st
+  and parseTycon : Syntax.etype parser =
+    fn st =>
+      bind parseSingleType parseTycons st
+  and parseTupleType : Syntax.etype parser =
+    fn st =>
+      bind (sepBy1 parseTycon (reserved "*")) (fn types =>
+      const
+        (case types of
+          [ty] => ty
+        | _ => Syntax.TyTuple types)) st
+  and parseType : Syntax.etype parser =
+    fn st =>
+      bind parseTupleType (fn ty =>
+          (reserved "->" >>
+          bind parseType (fn ty' =>
+          const (Syntax.Tyfun (ty, ty'))))
+      <|> const ty) st
+
+  fun leftOp (i : int) : string parser =
+    bind getUserState (fn {infixTable, ...} =>
+    let val (leftOps, _) = Vector.sub (infixTable, 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 {infixTable, ...} =>
+    let val (_, rightOps) = Vector.sub (infixTable, 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
+  <|> bind (between (symbol "(") (symbol ")") (sepBy pat (symbol ","))) (fn pats =>
+      const
+        (case pats of
+          [p] => p
+        | _ => Syntax.PTuple pats))
+  <|> bind longIdentifier (fn [i] => const (Syntax.PVar i) | is => const (Syntax.PCon (is, Syntax.PTuple [])))) st
+  and appPat : Syntax.pat parser = fn st =>
+      (bind longIdentifier (fn ident =>
+          bind atpat (fn arg =>
+          const (Syntax.PCon (ident, arg)))
+      <|> const (case ident of
+                  [i] => Syntax.PVar i
+                | _ => Syntax.PCon (ident, Syntax.PTuple [])))
+  <|> atpat) st
+  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 (List.mapPartial (fn x => x) decs, e)))))
+      <|> (symbol "(" >>
+           bind (sepBy expr (symbol ",")) (fn exprs =>
+           symbol ")" >>
+           const
+             (case exprs of
+               [x] => x
+             | _ => Syntax.ETuple exprs)))) st
+  and appExp : Syntax.expr parser =
+    fn st =>
+      bind atom (fn e0 =>
+      foldl (fn (x, acc) => Syntax.EApp (acc, x)) e0 <$> many atom) st
+  and infixExp : Syntax.expr parser =
+    fn st =>
+      foldl
+        (fn (i, exprLower) =>
+          let
+            fun exprLeft expr1 =
+              bind (leftOp i) (fn opEx =>
+              bind exprLower (fn 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 (Syntax.EIdent [opEx], Syntax.ETuple [expr1, rest])))))
+          in
+            bind exprLower (fn expr1 =>
+            exprLeft expr1 <|> exprRight expr1 <|> const expr1)
+          end)
+        appExp
+        (List.tabulate (10, fn i => 9 - i)) st
+  and typedExp : Syntax.expr parser =
+    fn st =>
+      bind infixExp (fn e =>
+          (reserved ":" >>
+          bind parseType (fn ty =>
+          const (Syntax.ETyped (e, ty))))
+      <|> const e) st
+  and andalsoExp : Syntax.expr parser =
+    fn st =>
+      bind typedExp (fn e1 =>
+          (reserved "andalso" >>
+          bind andalsoExp (fn e2 =>
+          const (Syntax.EAndAlso (e1, e2))))
+      <|> const e1) st
+  and orelseExpr : Syntax.expr parser =
+    fn st =>
+      bind andalsoExp (fn e1 =>
+          (reserved "orelse" >>
+          bind orelseExpr (fn e2 =>
+          const (Syntax.EOrElse (e1, e2))))
+      <|> const e1) st
+  and expr : Syntax.expr parser = fn st =>
+      ((reserved "fn" >>
+      bind pat (fn p =>
+      reserved "=>" >>
+      bind expr (fn e =>
+      const (Syntax.ELambda (p, e)))))
+  <|> (reserved "case" >>
+      bind expr (fn e =>
+      reserved "of" >>
+      bind
+        (sepBy1
+            (bind pat (fn p =>
+            reserved "=>" >>
+            bind expr (fn e =>
+            const (p, e))))
+          (reserved "|")) (fn arms =>
+      const (Syntax.ECase (e, arms)))))
+  <|> orelseExpr) st
+  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 {infixTable} =>
+          let val (leftOps, rightOps) = Vector.sub (infixTable, level)
+          in
+            if direction
+            then {infixTable = Vector.update (infixTable, level, (leftOps, ops @ rightOps))}
+            else {infixTable = Vector.update (infixTable, 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 (infixIdentifier <|> identifier) (fn con =>
+              (reserved "of" >>
+              bind parseType (fn ty =>
+              const (con, SOME ty)))
+          <|> const (con, NONE)))
+          (reserved "|")) (fn 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
+        (SOME
+          (if isRec
+          then Syntax.DValRec (p, e)
+          else Syntax.DVal (p, e)))))))
+  <|> (reserved "fun" >>
+      bind
+        (sepBy1
+          (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))))
+          (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 (SOME (Syntax.DFun (name, map (fn (_, x, y) => (x, y)) cases)))
+      end))) st
+
+  val rec strdec : Syntax.dec option parser = fn st =>
+      ((reserved "structure" >>
+      bind identifier (fn strID =>
+      reserved "=" >>
+      reserved "struct" >>
+      bind (many strdec) (fn bindings =>
+      reserved "end" >>
+      const (SOME (Syntax.DStruct (strID, List.mapPartial (fn x => x) bindings))))))
+  <|> dec) st
+
+  (* There's ambiguity between pattern variables and constructors that can only
+   * be resolved by checking for constructors in scope *)
+  fun fixPatConstructors (constructors : unit StringMap.map) (Syntax.PVar v) : Syntax.pat =
+        if isSome (StringMap.lookup v constructors)
+        then Syntax.PCon ([v], Syntax.PTuple [])
+        else Syntax.PVar v
+    | fixPatConstructors constructors (Syntax.PTuple pats) = Syntax.PTuple (map (fixPatConstructors constructors) pats)
+    | fixPatConstructors constructors (Syntax.PCon (con, arg)) = Syntax.PCon (con, fixPatConstructors constructors arg)
+    | fixPatConstructors _ pat = pat
+
+  fun findConstructors (Syntax.DDatatype (_, cases)) : string list =
+        List.mapPartial
+          (fn (constructor, NONE) => SOME constructor
+            | _ => NONE)
+          cases
+    | findConstructors _ = []
+
+  fun fixDecConstructors (constructors : unit StringMap.map) (Syntax.DVal (pat, body)) : Syntax.dec =
+        Syntax.DVal (fixPatConstructors constructors pat, fixConstructors constructors body)
+    | fixDecConstructors constructors (Syntax.DValRec (pat, body)) =
+        Syntax.DValRec (fixPatConstructors constructors pat, fixConstructors constructors body)
+    | fixDecConstructors constructors (Syntax.DFun (f, arms)) =
+        Syntax.DFun (f, map (fn (args, body) => (map (fixPatConstructors constructors) args, fixConstructors constructors body)) arms)
+    | fixDecConstructors _ (decl as Syntax.DDatatype _) = decl
+    | fixDecConstructors constructors (Syntax.DStruct (name, decs)) =
+        let
+          val constructors = ref constructors
+          val decs : Syntax.dec list =
+            map
+              (fn dec =>
+                (constructors := foldl (fn (x, acc) => StringMap.insert x () acc) (!constructors) (findConstructors dec) ;
+                fixDecConstructors (!constructors) dec))
+              decs
+        in Syntax.DStruct (name, decs)
+        end
+
+  and fixConstructors (constructors : unit StringMap.map) (Syntax.ETuple exprs) : Syntax.expr =
+        Syntax.ETuple (map (fixConstructors constructors) exprs)
+    | fixConstructors constructors (Syntax.EList exprs) =
+        Syntax.EList (map (fixConstructors constructors) exprs)
+    | fixConstructors constructors (Syntax.EApp (func, arg)) =
+        Syntax.EApp (fixConstructors constructors func, fixConstructors constructors arg)
+    | fixConstructors constructors (Syntax.ETyped (expr, ty)) =
+        Syntax.ETyped (fixConstructors constructors expr, ty)
+    | fixConstructors constructors (Syntax.EAndAlso (e1, e2)) =
+        Syntax.EAndAlso (fixConstructors constructors e1, fixConstructors constructors e2)
+    | fixConstructors constructors (Syntax.EOrElse (e1, e2)) =
+        Syntax.EOrElse (fixConstructors constructors e1, fixConstructors constructors e2)
+    | fixConstructors constructors (Syntax.ELet (decs, body)) =
+        let
+          val constructors = ref constructors
+          val decs =
+            map
+              (fn dec =>
+                (constructors := foldl (fn (x, acc) => StringMap.insert x () acc) (!constructors) (findConstructors dec) ;
+                fixDecConstructors (!constructors) dec))
+              decs
+        in Syntax.ELet (decs, fixConstructors (!constructors) body)
+        end
+    | fixConstructors constructors (Syntax.ELambda (pat, body)) =
+        Syntax.ELambda (fixPatConstructors constructors pat, fixConstructors constructors body)
+    | fixConstructors constructors (Syntax.ECase (expr, arms)) =
+        Syntax.ECase (fixConstructors constructors expr, map (fn (pat, expr) => (fixPatConstructors constructors pat, fixConstructors constructors expr)) arms)
+    | fixConstructors _ expr = expr
+
+  val program : Syntax.expr parser =
+    bind (many strdec) (fn decs =>
+    const (fixConstructors StringMap.empty (Syntax.ELet (List.mapPartial (fn x => x) decs, Syntax.EInt 0))))
+  fun parse (f : string) : (string, Syntax.expr) Result.either = runParser program f
+end