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 defaultInfixOperators : infixTable = Vector.fromList
    [ ([], [])
    , ([], [])
    , ([], [])
    , ([], [])
    , ([], [])
    , ([], ["::"])
    , ([], [])
    , ([], [])
    , ([], [])
    , ([], [])
    ]

  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 = defaultInfixOperators}
  }

  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 thunk (f : unit -> 'a parser) : 'a parser = fn st => f () st

  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 <$ try (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"

  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

  fun notFollowedBy (p : char parser) : unit parser =
    try (bind (try p) (fn c => unexpected (str c)) <|> const ())

  val comment : unit parser =
    parseString "(*" >>
    (* TODO: support nested comments (really?) *)
    many (() <$ satisfy (fn c => c <> #"*") <|> try (satisfy (fn _ => true) >> notFollowedBy (parseChar #")"))) >>
    parseString "*)" >>
    const ()

  (* some day, whiteSpace will support comments - that day is today *)
  val whiteSpace = many (() <$ space <|> comment) <?> "white space"

  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 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
  <|> (symbol "[" >>
      bind (sepBy pat (symbol ",")) (fn pats =>
      symbol "]" >>
      const (Syntax.PList pats)))
  <|> 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 typedPat : Syntax.pat parser = fn st =>
      (bind appPat (fn pat =>
      pat <$ (reserved ":" >> parseType) <|> const pat)) 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)
      typedPat
      (List.tabulate (10, fn i => 9 - i)) st

  fun makeConvolutedEDotSyntax (ty : Syntax.identType) ([i] : string list) : Syntax.expr =
        Syntax.EIdent (ty, i)
    | makeConvolutedEDotSyntax (ty : Syntax.identType) (i :: is : string list) : Syntax.expr =
        let
          fun go acc [i] = Syntax.EDot (acc, (ty, i))
            | go acc (i :: is) = go (Syntax.EDot (acc, (Syntax.ITStruct, i))) is
            | go _ _ = raise Fail "unreachable"
        in go (Syntax.EIdent (Syntax.ITStruct, i)) is end
    | makeConvolutedEDotSyntax _ _ = raise Fail "bad identifier"

  val rec atom : Syntax.expr parser =
    fn st =>
      (Syntax.EInt <$> integer
      <|> Syntax.EStr <$> stringConstant
      <|> makeConvolutedEDotSyntax Syntax.ITVar <$> longIdentifier
      <|> (reserved "op" >> makeConvolutedEDotSyntax Syntax.ITVar <$> 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 (Syntax.EList exprs)))
      <|> (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 (Syntax.ITVar, 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 (Syntax.ITVar, 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" <|> reserved "and") >>
      bind
            (between (symbol "(") (symbol ")") (sepBy1 tyvar (symbol ","))
        <|> (fn x => [x]) <$> tyvar
        <|> const []) (fn vars =>
      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 (vars, name, cons)))))))
  <|> (reserved "type" >>
      bind identifier (fn name =>
      reserved "=" >>
      bind parseType (fn ty =>
      const (SOME (Syntax.DType (name, ty))))))
  <|> (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 ":" >> () <$ parseType) <|> const ()) >>
          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 =>
      bind
        (((reserved ":" <|> reserved ":>") >>
          SOME <$> identifier)
        <|> const NONE)
        (fn s =>
      reserved "=" >>
      bind structExpr (fn str =>
      const (SOME (Syntax.DStruct (strID, s, str)))))))
  <|> dec) st
  and structExpr : Syntax.expr parser = fn st =>
        ((reserved "struct" >>
        bind (many strdec) (fn bindings =>
        reserved "end" >>
        const (Syntax.EStruct (List.mapPartial (fn x => x) bindings))))
    <|> bind longIdentifier (fn is =>
        (symbol "(" >>
          thunk (fn () => if length is <> 1 then raise Fail "bad functor has a dot" else
          bind structExpr (fn arg =>
          symbol ")" >>
          const (Syntax.EFunctorApp (Syntax.EIdent (Syntax.ITFunctor, hd is), arg)))))
        <|> const (makeConvolutedEDotSyntax Syntax.ITStruct is))) 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 _ (decl as Syntax.DType _) = decl
    | fixDecConstructors constructors (Syntax.DStruct (name, s, str)) = Syntax.DStruct (name, s, fixConstructors constructors str)
    | fixDecConstructors constructors (s as Syntax.DSig _) = s
    | fixDecConstructors constructors (Syntax.DFunctor (name, arg, ty, body)) = Syntax.DFunctor (name, arg, ty, fixConstructors constructors body)

  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 constructors (Syntax.EStruct decls) =
        let val constructors = ref constructors in
          Syntax.EStruct
            (map
              (fn dec =>
                (constructors := foldl (fn (x, acc) => StringMap.insert x () acc) (!constructors) (findConstructors dec) ;
                fixDecConstructors (!constructors) dec))
              decls)
        end
    | fixConstructors _ expr = expr

  val spec : (string * Syntax.etype) parser =
    reserved "val" >>
    bind identifier (fn id =>
    reserved ":" >>
    bind parseType (fn ty =>
    const (id, ty)))

  val sigexp : (string * Syntax.etype) list parser =
    between (reserved "sig") (reserved "end") (many spec)

  val sigdec : Syntax.dec parser =
    reserved "signature" >>
    bind identifier (fn sigID =>
    reserved "=" >>
    bind sigexp (fn vals =>
    const (Syntax.DSig (sigID, vals))))

  val fundec : Syntax.dec parser =
    reserved "functor" >>
    bind identifier (fn funID =>
    symbol "(" >>
    bind identifier (fn arg =>
    reserved ":" >>
    bind identifier (fn sigID =>
    symbol ")" >>
    reserved "=" >>
    reserved "struct" >>
    bind (many strdec) (fn bindings =>
    reserved "end" >>
    const (Syntax.DFunctor (funID, arg, sigID, Syntax.EStruct (List.mapPartial (fn x => x) bindings)))))))

  val topdec : Syntax.dec option parser =
    strdec <|> SOME <$> sigdec <|> SOME <$> fundec

  val program : Syntax.expr parser =
    whiteSpace >>
    bind (many topdec) (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