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) Either.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"
    , "(", ")", "[", "]", "{", "}", ",", ":", ";", "...", "_", "|", "=", "=>", "->", "#"
    ]

  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, Either.Left err : (parseError, 'a * state * hints) Either.either) : (string, 'a) Either.either =
        Either.Left (printError err)
    | unpackParserResponse (_, Either.Right (a, st, _)) =
        if TextIO.StreamIO.endOfStream (stateStream st)
        then Either.Right a
        else Either.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, Either.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) Either.either =
    unpackParserResponse (p (newState fileName (TextIO.openIn fileName)))

  fun testParser (p : 'a parser) (s : string) : (string, 'a) Either.either =
    unpackParserResponse (p (newState "STRING" (TextIO.openString s)))

  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, Either.Right (a, st', hints)) =>
          (case (f a) st' of
            (Consumed, Either.Right success) => (Consumed, Either.Right success)
          | (Empty, Either.Right (b, st'', hints')) => (consumed1, Either.Right (b, st'', mergeHints hints hints'))
          | (Consumed, Either.Left err) => (Consumed, Either.Left (withHints hints err))
          | (Empty, Either.Left err) => (consumed1, Either.Left (withHints hints err)))
      | (consumed, Either.Left err) => (consumed, Either.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, Either.Right (a, st', _)) => (consumed, Either.Right (a, st', Hints [msg]))
      | (consumed, Either.Left (ParseError (loc, _))) => (consumed, Either.Left (ParseError (loc, [Expected msg])))

  fun (p1 : 'a parser) <|> (p2 : 'a parser) : 'a parser =
    fn st =>
      case p1 st of
        (Empty, Either.Left err) =>
          (case p2 st of
            (Empty, Either.Right (a, st', hints)) => (Empty, Either.Right (a, st', mergeHints (errToHints err) hints))
          | (Empty, Either.Left err') => (Empty, Either.Left (mergeError err err'))
          | res => res)
      | res => res

  fun const (x : 'a) (st : state) = (Empty, Either.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, Either.Left err) => (Empty, Either.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, Either.Left (ParseError (loc, [Expected "UNKNOWN"])))
      | SOME (c, stream') =>
          if pred c
          then (Consumed, Either.Right (c, State (stream', updatePosChar loc c, us), Hints []))
          else (Empty, Either.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 <?> 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, Either.Right (x, s'', _)) => walk (x :: xs) s''
            | (Consumed, Either.Left err) => (Consumed, Either.Left err)
            | (Empty, Either.Right _) => manyErr ()
            | (Empty, Either.Left err) => (Consumed, Either.Right (rev xs, s', errToHints err))
      in
        case p st of
          (Consumed, Either.Right (x, s', _)) => walk [x] s'
        | (Consumed, Either.Left err) => (Consumed, Either.Left err)
        | (Empty, Either.Right _) => manyErr ()
        | (Empty, Either.Left err) => (Empty, Either.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, Either.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 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))

  fun symbol (s : string) : string parser = lexeme (parseString s)

  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 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 => Syntax.EIdent <$> 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 => Syntax.EIdent <$> foldl (op <|>) op1 ops
    end)

  (* Values cannot be recursive, so we write each expression parser as a lambda. *)
  val rec atom : Syntax.expr parser =
    fn st =>
      (Syntax.EInt <$> integer
      <|> Syntax.EStr <$> stringConstant
      <|> Syntax.EIdent <$> identifier
      <|> (symbol "(" >>
           bind (sepBy1 expr (symbol ",")) (fn exprs =>
           symbol ")" >>
           const
             (case exprs of
               [x] => x
             | _ => Syntax.ETuple exprs)))) st
  and expr0 : Syntax.expr parser =
    fn st =>
      bind atom (fn e0 =>
      foldl (fn (x, acc) => Syntax.EApp (acc, x)) e0 <$> many atom) st
  and expr : 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)
        expr0
        (List.tabulate (10, fn i => 9 - i)) st
end