infix 4 <$> <$
infix 1 >>
infixr 1 <|>
infix 0 <?>

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 sourceLoc = SourceLoc of string * int * int  (* file * row * column *)
  datatype state = State of TextIO.StreamIO.instream * sourceLoc * userState
  datatype response = Consumed | Empty
  datatype message = Unexpected of string | Expected of string
  datatype parseError = ParseError of sourceLoc * 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 =
    Vector.fromList
      [ (["before"], [])
      , ([], [])
      , ([], [])
      , ([":=", "o"], [])
      , (["=", "<>", ">", ">=", "<", "<="], [])
      , (["@@"], ["::", "@"])
      , (["+", "-", "^"], [])
      , (["*", "/", "div", "mod"], [])
      , ([], [])
      , ([], [])
      ]

  fun printSourceLoc (SourceLoc (fileName, row, col)) : string =
    fileName ^ ":" ^ Int.toString row ^ "." ^ Int.toString col

  fun printError (ParseError (loc, msgs)) : 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 stateStream (State (stream, _, _)) : TextIO.StreamIO.instream = stream

  fun stateLoc (State (_, loc, _)) : sourceLoc = loc

  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 (stateStream st)
        then Result.Right a
        else Result.Left (printSourceLoc (stateLoc st) ^ " Syntax error: trailing characters")

  fun newLoc (fileName : string) : sourceLoc = SourceLoc (fileName, 1, 1)

  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 newState (fileName : string) (fileStream : TextIO.instream) : state =
    State (TextIO.getInstream fileStream, newLoc fileName, makeUserState defaultInfixOperators)

  fun updateUserState (f : userState -> userState) : userState parser =
    fn State (stream, loc, us) =>
      let val st' = f us
      in (Empty, Result.Right (st', State (stream, loc, 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) (ParseError (loc, msgs)) : parseError = ParseError (loc, map Expected hints @ msgs)

  fun errToHints (ParseError (_, msgs)) = Hints (List.mapPartial (fn Expected s => SOME s | _ => NONE) msgs)

  fun compareLoc (SourceLoc (_, r1, c1), SourceLoc (_, r2, c2)) : order =
    case Int.compare (r1, r2) of
      EQUAL => Int.compare (c1, c2)
    | ord => ord

  fun mergeError (e1 as ParseError (loc1, msgs1)) (e2 as ParseError (loc2, msgs2)) : parseError =
    (* pick the longest match *)
    case compareLoc (loc1, loc2) of
      EQUAL => ParseError (loc1, msgs1 @ msgs2)
    | 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 (ParseError (loc, _))) => (consumed, Result.Left (ParseError (loc, [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 (p : 'a parser) <$ (x : 'b) : 'b 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 (SourceLoc (file, row, column)) (c : char) : sourceLoc =
    case c of
      #"\n" => SourceLoc (file, row + 1, 1)
    | #"\t" => SourceLoc (file, row, column + 8 - (column - 1) mod 8)
    | _ => SourceLoc (file, row, column + 1)

  fun satisfy (pred : char -> bool) : char parser =
    fn State (stream, loc, us) =>
      case TextIO.StreamIO.input1 stream of
        NONE => (Empty, Result.Left (ParseError (loc, [Expected "UNKNOWN"])))
      | SOME (c, stream') =>
          if pred c
          then (Consumed, Result.Right (c, State (stream', updatePosChar loc c, us), Hints []))
          else (Empty, Result.Left (ParseError (loc, [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 => foldl (fn (c, p) => p >> parseChar c) (parseChar c1) cs <$ s <?> "'" ^ 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 st => (Empty, Result.Left (ParseError (stateLoc st, [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 <|> parseChar #"'") (fn firstLetter =>
      bind (many alphaNumIdentifierLetter) (fn rest =>
      const (implode (firstLetter :: rest)))))

  val symbolicIdentifier : string parser =
    lexeme
      (implode <$> many1 symbolicIdentifierLetter)

  val identifier : 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
      then unexpected identName
      else const identName)))

  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 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 "\\" >> (parseChar #"a" <$ #"\a"
                         <|> parseChar #"b" <$ #"\b"
                         <|> parseChar #"t" <$ #"\t"
                         <|> parseChar #"n" <$ #"\n"
                         <|> parseChar #"v" <$ #"\v"
                         <|> parseChar #"f" <$ #"\f"
                         <|> parseChar #"r" <$ #"\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 parseTycons (ty : Syntax.etype) : Syntax.etype parser =
        bind identifier (fn longtycon =>
        parseTycons (Syntax.Tycon ([ty], longtycon)))
    <|> const ty

  val rec parseSingleType : Syntax.etype parser =
    fn st =>
      (Syntax.Tyvar <$> identifier
      <|> (symbol "(" >>
          bind (sepBy1 parseType (symbol ",")) (fn types =>
          symbol ")" >>
          (case types of
            [x] => const x
          | _ => bind identifier (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 (symbol "*")) (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) : 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)

  val rec atom : Syntax.expr parser =
    fn st =>
      (Syntax.EInt <$> integer
      <|> Syntax.EStr <$> stringConstant
      <|> Syntax.EIdent <$> longIdentifier
      <|> builtin
      <|> (reserved "let" >>
           bind (many dec) (fn decs =>
           reserved "in" >>
           bind expr (fn e =>
           reserved "end" >>
           const (Syntax.ELet (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 (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])))))
          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 handleExpr : Syntax.expr parser = fn st => orelseExpr st
  and raiseExpr : Syntax.expr parser = fn st => handleExpr st
  and fnExpr : Syntax.expr parser = fn st => ((reserved "fn" >> reserved "_" >> reserved "=>" >> Syntax.ELambda <$> expr) <|> raiseExpr) st
  and expr : Syntax.expr parser = fn st => fnExpr st
  and dec : Syntax.dec parser = fn st => (reserved "val" >> reserved "_" >> reserved "=" >> Syntax.DVal <$> expr) st

  val program : Syntax.expr parser = (fn decs => Syntax.ELet (decs, Syntax.EInt 0)) <$> many dec
  fun parse (f : string) : (string, Syntax.expr) Result.either = runParser program f
end