diff options
| -rw-r--r-- | either.sml | 4 | ||||
| -rw-r--r-- | parser.sml | 352 | ||||
| -rw-r--r-- | syntax.sml | 9 |
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 |