Add a simple expression parser.

3 files changed, 365 insertions, 0 deletions

diff --git a/either.sml b/either.sml
new file mode 100644
index 0000000..6a63fe5
--- /dev/null
+++ b/either.sml
@@ -0,0 +1,4 @@
+structure Either =
+struct
+  datatype ('a, 'b) either = Left of 'a | Right of 'b
+end
diff --git a/parser.sml b/parser.sml
new file mode 100644
index 0000000..219b61f
--- /dev/null
+++ b/parser.sml
@@ -0,0 +1,352 @@
+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 parserResponse = response * (parseError, 'a * state * hints) Either.either
+  type 'a parser = state -> 'a parserResponse
+
+  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 -> infixTable) (State (stream, loc, us) : state) : userState parserResponse =
+    let val st' = makeUserState (f us)
+    in (Empty, Either.Right (st', State (stream, loc, st'), Hints []))
+    end
+
+  val getUserState : userState parser = updateUserState (fn (UserState (_, opTable)) => opTable)
+
+  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) (st : state) : 'b parserResponse =
+    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) (st : state) : 'a parserResponse =
+    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) (State (stream, loc, us) : state) : char parserResponse =
+    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) (st : state) : 'a list parserResponse =
+    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) (st : state) : 'a parserResponse =
+    (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)
+
+  (* These need to be declared as functions so they can be mutually recursive.
+     Of course, functions are values. *)
+  fun atom (st : state) : Syntax.expr parserResponse =
+    (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 (st : state) : Syntax.expr parserResponse =
+    bind atom (fn e0 =>
+    foldl (fn (x, acc) => Syntax.EApp (acc, x)) e0 <$> many atom) st
+  and expr (st : state) : Syntax.expr parserResponse =
+    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
diff --git a/syntax.sml b/syntax.sml
new file mode 100644
index 0000000..fbb61bd
--- /dev/null
+++ b/syntax.sml
@@ -0,0 +1,9 @@
+structure Syntax =
+struct
+  datatype expr = EIdent of string
+                | EInt of int
+                | EStr of string
+                | ETuple of expr list
+                | EList of expr list
+                | EApp of expr * expr
+end