Combine structs and expressions

1 files changed, 70 insertions, 45 deletions

diff --git a/Parser.sml b/Parser.sml
index a967880..8f43352 100644
--- a/Parser.sml
+++ b/Parser.sml
@@ -123,6 +123,8 @@ struct
           | (Empty, Result.Left err) => (consumed1, Result.Left (withHints hints err)))
       | (consumed, Result.Left err) => (consumed, Result.Left err)
 
+  fun thunk (f : unit -> 'a parser) : 'a parser = fn st => f () st
+
   fun (p1 : 'a parser) >> (p2 : 'b parser) : 'b parser = bind p1 (fn _ => p2)
 
   fun (p : 'a parser) <?> (msg : string) : 'a parser =
@@ -451,25 +453,22 @@ struct
       typedPat
       (List.tabulate (10, fn i => 9 - i)) st
 
-  fun makeConvolutedEDotSyntax ([i] : string list) : Syntax.expr = Syntax.EIdent i
-    | makeConvolutedEDotSyntax (i :: is) =
+  fun makeConvolutedEDotSyntax (ty : Syntax.identType) ([i] : string list) : Syntax.expr =
+        Syntax.EIdent (ty, i)
+    | makeConvolutedEDotSyntax (ty : Syntax.identType) (i :: is : string list) : Syntax.expr =
         let
-          val structSelectors = List.take (is, length is - 1)
-          val exprSelector = List.last is
-        in
-          Syntax.EDot
-            ( foldl (fn (x, acc) => Syntax.SDot (acc, x)) (Syntax.SIdent i) structSelectors
-            , exprSelector
-            )
-        end
-    | makeConvolutedEDotSyntax _ = raise Fail "bad identifier"
+          fun go acc [i] = Syntax.EDot (acc, (ty, i))
+            | go acc (i :: is) = go (Syntax.EDot (acc, (Syntax.ITStruct, i))) is
+            | go _ _ = raise Fail "unreachable"
+        in go (Syntax.EIdent (Syntax.ITStruct, i)) is end
+    | makeConvolutedEDotSyntax _ _ = raise Fail "bad identifier"
 
   val rec atom : Syntax.expr parser =
     fn st =>
       (Syntax.EInt <$> integer
       <|> Syntax.EStr <$> stringConstant
-      <|> makeConvolutedEDotSyntax <$> longIdentifier
-      <|> (reserved "op" >> makeConvolutedEDotSyntax <$> longInfixIdentifier)
+      <|> makeConvolutedEDotSyntax Syntax.ITVar <$> longIdentifier
+      <|> (reserved "op" >> makeConvolutedEDotSyntax Syntax.ITVar <$> longInfixIdentifier)
       <|> builtin
       <|> (reserved "let" >>
            bind (many dec) (fn decs =>
@@ -496,14 +495,14 @@ struct
             fun exprLeft expr1 =
               bind (leftOp i) (fn opEx =>
               bind exprLower (fn expr2 =>
-              let val app = Syntax.EApp (Syntax.EIdent opEx, Syntax.ETuple [expr1, expr2])
+              let val app = Syntax.EApp (Syntax.EIdent (Syntax.ITVar, 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 (Syntax.EIdent opEx, Syntax.ETuple [expr1, rest])))))
+              const (Syntax.EApp (Syntax.EIdent (Syntax.ITVar, opEx), Syntax.ETuple [expr1, rest])))))
           in
             bind exprLower (fn expr1 =>
             exprLeft expr1 <|> exprRight expr1 <|> const expr1)
@@ -605,6 +604,7 @@ struct
                   bind (many1 atpat) (fn args =>
                   const (name, args))
               | _ => unexpected "pattern"))) (fn (name, args) =>
+          ((reserved ":" >> () <$ parseType) <|> const ()) >>
           reserved "=" >>
           bind expr (fn body =>
           const (name, args, body))))
@@ -627,27 +627,19 @@ struct
       reserved "=" >>
       bind structExpr (fn str =>
       const (SOME (Syntax.DStruct (strID, s, str)))))))
-  <|> (reserved "signature" >>
-      bind identifier (fn sigID =>
-      reserved "=" >>
-      reserved "sig" >>
-      bind
-        (many
-          (reserved "val" >>
-          bind identifier (fn id =>
-          reserved ":" >>
-          bind parseType (fn ty =>
-          const (id, ty)))))
-        (fn bindings =>
-      reserved "end" >>
-      const (SOME (Syntax.DSig (sigID, bindings))))))
   <|> dec) st
-  and structExpr : Syntax.structExpr parser = fn st =>
+  and structExpr : Syntax.expr parser = fn st =>
         ((reserved "struct" >>
         bind (many strdec) (fn bindings =>
         reserved "end" >>
-        const (Syntax.SStruct (List.mapPartial (fn x => x) bindings))))
-    <|> (fn is => foldl (fn (x, acc) => Syntax.SDot (acc, x)) (Syntax.SIdent (hd is)) (tl is)) <$> longIdentifier) st
+        const (Syntax.EStruct (List.mapPartial (fn x => x) bindings))))
+    <|> bind longIdentifier (fn is =>
+        (symbol "(" >>
+          thunk (fn () => if length is <> 1 then raise Fail "bad functor has a dot" else
+          bind structExpr (fn arg =>
+          symbol ")" >>
+          const (Syntax.EFunctorApp (Syntax.EIdent (Syntax.ITFunctor, hd is), arg)))))
+        <|> const (makeConvolutedEDotSyntax Syntax.ITStruct is))) st
 
   (* There's ambiguity between pattern variables and constructors that can only
    * be resolved by checking for constructors in scope *)
@@ -674,19 +666,9 @@ struct
         Syntax.DFun (f, map (fn (args, body) => (map (fixPatConstructors constructors) args, fixConstructors constructors body)) arms)
     | fixDecConstructors _ (decl as Syntax.DDatatype _) = decl
     | fixDecConstructors _ (decl as Syntax.DType _) = decl
-    | fixDecConstructors constructors (Syntax.DStruct (name, s, str)) = Syntax.DStruct (name, s, fixStructExprConstructors constructors str)
+    | fixDecConstructors constructors (Syntax.DStruct (name, s, str)) = Syntax.DStruct (name, s, fixConstructors constructors str)
     | fixDecConstructors constructors (s as Syntax.DSig _) = s
-
-  and fixStructExprConstructors (constructors : unit StringMap.map) (Syntax.SStruct decls) : Syntax.structExpr =
-        let val constructors = ref constructors in
-          Syntax.SStruct
-            (map
-              (fn dec =>
-                (constructors := foldl (fn (x, acc) => StringMap.insert x () acc) (!constructors) (findConstructors dec) ;
-                fixDecConstructors (!constructors) dec))
-              decls)
-        end
-    | fixStructExprConstructors _ expr = expr
+    | fixDecConstructors constructors (Syntax.DFunctor (name, arg, ty, body)) = Syntax.DFunctor (name, arg, ty, fixConstructors constructors body)
 
   and fixConstructors (constructors : unit StringMap.map) (Syntax.ETuple exprs) : Syntax.expr =
         Syntax.ETuple (map (fixConstructors constructors) exprs)
@@ -715,11 +697,54 @@ struct
         Syntax.ELambda (fixPatConstructors constructors pat, fixConstructors constructors body)
     | fixConstructors constructors (Syntax.ECase (expr, arms)) =
         Syntax.ECase (fixConstructors constructors expr, map (fn (pat, expr) => (fixPatConstructors constructors pat, fixConstructors constructors expr)) arms)
+    | fixConstructors constructors (Syntax.EStruct decls) =
+        let val constructors = ref constructors in
+          Syntax.EStruct
+            (map
+              (fn dec =>
+                (constructors := foldl (fn (x, acc) => StringMap.insert x () acc) (!constructors) (findConstructors dec) ;
+                fixDecConstructors (!constructors) dec))
+              decls)
+        end
     | fixConstructors _ expr = expr
 
+  val spec : (string * Syntax.etype) parser =
+    reserved "val" >>
+    bind identifier (fn id =>
+    reserved ":" >>
+    bind parseType (fn ty =>
+    const (id, ty)))
+
+  val sigexp : (string * Syntax.etype) list parser =
+    between (reserved "sig") (reserved "end") (many spec)
+
+  val sigdec : Syntax.dec parser =
+    reserved "signature" >>
+    bind identifier (fn sigID =>
+    reserved "=" >>
+    bind sigexp (fn vals =>
+    const (Syntax.DSig (sigID, vals))))
+
+  val fundec : Syntax.dec parser =
+    reserved "functor" >>
+    bind identifier (fn funID =>
+    symbol "(" >>
+    bind identifier (fn arg =>
+    reserved ":" >>
+    bind identifier (fn sigID =>
+    symbol ")" >>
+    reserved "=" >>
+    reserved "struct" >>
+    bind (many strdec) (fn bindings =>
+    reserved "end" >>
+    const (Syntax.DFunctor (funID, arg, sigID, Syntax.EStruct (List.mapPartial (fn x => x) bindings)))))))
+
+  val topdec : Syntax.dec option parser =
+    strdec <|> SOME <$> sigdec <|> SOME <$> fundec
+
   val program : Syntax.expr parser =
     whiteSpace >>
-    bind (many strdec) (fn decs =>
+    bind (many topdec) (fn decs =>
     const (fixConstructors StringMap.empty (Syntax.ELet (List.mapPartial (fn x => x) decs, Syntax.EInt 0))))
   fun parse (f : string) : (string, Syntax.expr) Result.either = runParser program f
 end