Add module syntax to the parser.

1 files changed, 94 insertions, 16 deletions

diff --git a/parser.sml b/parser.sml
index a907edf..1860344 100644
--- a/parser.sml
+++ b/parser.sml
@@ -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