diff options
| -rw-r--r-- | parser.sml | 110 |
1 files changed, 94 insertions, 16 deletions
@@ -22,6 +22,8 @@ struct , "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 = @@ -87,8 +89,10 @@ struct 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 testParser (p : 'a parser) (s : string) : 'a = + case unpackParserResponse (p (newState "STRING" (TextIO.openString s))) of + Either.Right x => x + | Either.Left e => raise Fail ("Parse failed: " ^ e) fun mergeHints (Hints a) (Hints b) : hints = Hints (a @ b) @@ -170,7 +174,7 @@ struct 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 + | 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" @@ -245,6 +249,18 @@ struct 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 () @@ -291,12 +307,42 @@ struct parseString "\"" >> const stringContent)) - fun symbol (s : string) : string parser = lexeme (parseString s) + val builtin : Syntax.expr parser = + reserved "__builtin" >> + Syntax.EBuiltin <$> stringConstant - 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 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) => @@ -304,7 +350,7 @@ struct in case (map reserved leftOps) of [] => unexpected "left-associative operator" - | op1 :: ops => Syntax.EIdent <$> foldl (op <|>) op1 ops + | op1 :: ops => (fn x => Syntax.EIdent [x]) <$> foldl (op <|>) op1 ops end) fun rightOp (i : int) : Syntax.expr parser = @@ -313,27 +359,33 @@ struct in case (map reserved rightOps) of [] => unexpected "right-associative operator" - | op1 :: ops => Syntax.EIdent <$> foldl (op <|>) op1 ops + | op1 :: ops => (fn x => Syntax.EIdent [x]) <$> 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 + <|> 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 (sepBy1 expr (symbol ",")) (fn exprs => + bind (sepBy expr (symbol ",")) (fn exprs => symbol ")" >> const (case exprs of [x] => x | _ => Syntax.ETuple exprs)))) st - and expr0 : Syntax.expr parser = + and appExp : 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 = + and infixExp : Syntax.expr parser = fn st => foldl (fn (i, exprLower) => @@ -353,6 +405,32 @@ struct bind exprLower (fn expr1 => exprLeft expr1 <|> exprRight expr1 <|> const expr1) end) - expr0 + 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 => typedExp 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.ETuple [])) <$> many dec + fun parse (f : string) : (string, Syntax.expr) Either.either = runParser program f end |