Starting with closure links

17 files changed, 299 insertions, 10 deletions

diff --git a/src/compiler.sig b/src/compiler.sig
index 62d38308..eca871f8 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -43,6 +43,7 @@ signature COMPILER = sig
     val explify : job -> Expl.file option
     val corify : job -> Core.file option
     val shake' : job -> Core.file option
+    val tag : job -> Core.file option
     val reduce : job -> Core.file option
     val shake : job -> Core.file option
     val monoize : job -> Mono.file option
@@ -54,6 +55,7 @@ signature COMPILER = sig
     val testExplify : job -> unit
     val testCorify : job -> unit
     val testShake' : job -> unit
+    val testTag : job -> unit
     val testReduce : job -> unit
     val testShake : job -> unit
     val testMonoize : job -> unit
diff --git a/src/compiler.sml b/src/compiler.sml
index 1f063633..e54fe5b4 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -196,8 +196,17 @@ fun shake' job =
         else
             SOME (Shake.shake file)
 
+fun tag job =
+    case shake' job of
+        NONE => NONE
+      | SOME file =>
+        if ErrorMsg.anyErrors () then
+            NONE
+        else
+            SOME (Tag.tag file)
+
 fun reduce job =
-    case corify job of
+    case tag job of
         NONE => NONE
       | SOME file =>
         if ErrorMsg.anyErrors () then
@@ -285,6 +294,15 @@ fun testShake' job =
     handle CoreEnv.UnboundNamed n =>
            print ("Unbound named " ^ Int.toString n ^ "\n")
 
+fun testTag job =
+    (case tag job of
+         NONE => print "Failed\n"
+       | SOME file =>
+         (Print.print (CorePrint.p_file CoreEnv.empty file);
+          print "\n"))
+    handle CoreEnv.UnboundNamed n =>
+           print ("Unbound named " ^ Int.toString n ^ "\n")
+
 fun testReduce job =
     (case reduce job of
          NONE => print "Failed\n"
diff --git a/src/core.sml b/src/core.sml
index fe969d18..69eafd33 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -76,6 +76,8 @@ datatype exp' =
 
        | EWrite of exp
 
+       | EClosure of int * exp list
+
 withtype exp = exp' located
 
 datatype decl' =
diff --git a/src/core_print.sml b/src/core_print.sml
index b1cc9c2d..60ad619f 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -232,6 +232,12 @@ fun p_exp' par env (e, _) =
                          p_exp env e,
                          string ")"]
 
+      | EClosure (n, es) => box [string "CLOSURE(",
+                                 p_enamed env n,
+                                 p_list_sep (string "") (fn e => box [string ", ",
+                                                                      p_exp env e]) es,
+                                 string ")"]
+
 and p_exp env = p_exp' false env
 
 fun p_decl env ((d, _) : decl) =
diff --git a/src/core_util.sig b/src/core_util.sig
index 423b93b4..5629e8fa 100644
--- a/src/core_util.sig
+++ b/src/core_util.sig
@@ -121,6 +121,12 @@ structure Decl : sig
                 exp : Core.exp' * 'state -> 'state,
                 decl : Core.decl' * 'state -> 'state}
                -> 'state -> Core.decl -> 'state
+
+    val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state,
+                   con : Core.con' * 'state -> Core.con' * 'state,
+                   exp : Core.exp' * 'state -> Core.exp' * 'state,
+                   decl : Core.decl' * 'state -> Core.decl' * 'state}
+                  -> 'state -> Core.decl -> Core.decl * 'state
 end
 
 structure File : sig
@@ -151,6 +157,12 @@ structure File : sig
                 exp : Core.exp' * 'state -> 'state,
                 decl : Core.decl' * 'state -> 'state}
                -> 'state -> Core.file -> 'state
+
+    val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state,
+                   con : Core.con' * 'state -> Core.con' * 'state,
+                   exp : Core.exp' * 'state -> Core.exp' * 'state,
+                   decl : Core.decl' * 'state -> Core.decl' * 'state}
+                  -> 'state -> Core.file -> Core.file * 'state
 end
 
 end
diff --git a/src/core_util.sml b/src/core_util.sml
index 11d70de9..427a313d 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -291,6 +291,11 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
                 S.map2 (mfe ctx e,
                      fn e' =>
                         (EWrite e', loc))
+
+              | EClosure (n, es) =>
+                S.map2 (ListUtil.mapfold (mfe ctx) es,
+                     fn es' =>
+                        (EClosure (n, es'), loc))
     in
         mfe
     end
@@ -401,6 +406,14 @@ fun fold {kind, con, exp, decl} s d =
         S.Continue (_, s) => s
       | S.Return _ => raise Fail "CoreUtil.Decl.fold: Impossible"
 
+fun foldMap {kind, con, exp, decl} s d =
+    case mapfold {kind = fn k => fn s => S.Continue (kind (k, s)),
+                  con = fn c => fn s => S.Continue (con (c, s)),
+                  exp = fn e => fn s => S.Continue (exp (e, s)),
+                  decl = fn d => fn s => S.Continue (decl (d, s))} d s of
+        S.Continue v => v
+      | S.Return _ => raise Fail "CoreUtil.Decl.foldMap: Impossible"
+
 end
 
 structure File = struct
@@ -456,6 +469,14 @@ fun fold {kind, con, exp, decl} s d =
         S.Continue (_, s) => s
       | S.Return _ => raise Fail "CoreUtil.File.fold: Impossible"
 
+fun foldMap {kind, con, exp, decl} s d =
+    case mapfold {kind = fn k => fn s => S.Continue (kind (k, s)),
+                  con = fn c => fn s => S.Continue (con (c, s)),
+                  exp = fn e => fn s => S.Continue (exp (e, s)),
+                  decl = fn d => fn s => S.Continue (decl (d, s))} d s of
+        S.Continue v => v
+      | S.Return _ => raise Fail "CoreUtil.File.foldMap: Impossible"
+
 end
 
 end
diff --git a/src/corify.sml b/src/corify.sml
index faeda0d1..9c44140d 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -358,7 +358,8 @@ fun corifyExp st (e, loc) =
       | L.ECApp (e1, c) => (L'.ECApp (corifyExp st e1, corifyCon st c), loc)
       | L.ECAbs (x, k, e1) => (L'.ECAbs (x, corifyKind k, corifyExp st e1), loc)
 
-      | L.ERecord xes => (L'.ERecord (map (fn (c, e, t) => (corifyCon st c, corifyExp st e, corifyCon st t)) xes), loc)
+      | L.ERecord xes => (L'.ERecord (map (fn (c, e, t) =>
+                                              (corifyCon st c, corifyExp st e, corifyCon st t)) xes), loc)
       | L.EField (e1, c, {field, rest}) => (L'.EField (corifyExp st e1, corifyCon st c,
                                                        {field = corifyCon st field, rest = corifyCon st rest}), loc)
       | L.EFold k => (L'.EFold (corifyKind k), loc)
@@ -450,8 +451,8 @@ fun corifyDecl ((d, loc : EM.span), st) =
                                  (case (#1 dom, #1 ran) of
                                       (L.TRecord _,
                                        L.CApp ((L.CModProj (_, [], "xml"), _),
-                                               (L.TRecord (L.CRecord (_, [((L.CName "Html", _),
-                                                                           _)]), _), _))) =>
+                                               (L.CRecord (_, [((L.CName "Html", _),
+                                                                _)]), _))) =>
                                       let
                                           val ran = (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc)
                                           val e = (L.EModProj (m, ms, s), loc)
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 8d676f4a..a95b2952 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -451,6 +451,7 @@ fun p_decl env ((d, _) : decl) =
                                      space,
                                      p_con env c2]
       | DExport (_, sgn, str) => box [string "export",
+                                      space,
                                       p_str env str,
                                       space,
                                       string ":",
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 81b3e8c4..af5c6c95 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1945,13 +1945,12 @@ fun elabDecl ((d, loc), (env, denv, gs)) =
                                      (case (hnormCon (env, denv) dom, hnormCon (env, denv) ran) of
                                           (((L'.TRecord domR, _), []),
                                            ((L'.CApp (tf, ranR), _), [])) =>
-                                          (case hnormCon (env, denv) ranR of
-                                               (ranR, []) =>
+                                          (case (hnormCon (env, denv) tf, hnormCon (env, denv) ranR) of
+                                               ((tf, []), (ranR, [])) =>
                                                (case (hnormCon (env, denv) domR, hnormCon (env, denv) ranR) of
                                                     ((domR, []), (ranR, [])) =>
                                                     (L'.SgiVal (x, n, (L'.TFun ((L'.TRecord domR, loc),
-                                                                                (L'.CApp (tf,
-                                                                                          (L'.TRecord ranR, loc)), loc)),
+                                                                                (L'.CApp (tf, ranR), loc)),
                                                                        loc)), loc)
                                                   | _ => all)
                                              | _ => all)
diff --git a/src/lacweb.grm b/src/lacweb.grm
index 914f3551..2cc23e78 100644
--- a/src/lacweb.grm
+++ b/src/lacweb.grm
@@ -281,6 +281,7 @@ eterm  : LPAREN eexp RPAREN             (#1 eexp, s (LPARENleft, RPARENright))
 
        | path                           (EVar path, s (pathleft, pathright))
        | LBRACE rexp RBRACE             (ERecord rexp, s (LBRACEleft, RBRACEright))
+       | UNIT                           (ERecord [], s (UNITleft, UNITright))
 
        | INT                            (EPrim (Prim.Int INT), s (INTleft, INTright))
        | FLOAT                          (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
@@ -345,3 +346,4 @@ attr   : SYMBOL EQ attrv                ((CName (uppercaseFirst SYMBOL), s (SYMB
 attrv  : INT                            (EPrim (Prim.Int INT), s (INTleft, INTright))
        | FLOAT                          (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
        | STRING                         (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
+       | LBRACE eexp RBRACE             (eexp)
diff --git a/src/lacweb.lex b/src/lacweb.lex
index 41163a61..b54d9e21 100644
--- a/src/lacweb.lex
+++ b/src/lacweb.lex
@@ -227,8 +227,10 @@ notags = [^<{\n]+;
 <INITIAL> ")"         => (Tokens.RPAREN (pos yypos, pos yypos + size yytext));
 <INITIAL> "["         => (Tokens.LBRACK (pos yypos, pos yypos + size yytext));
 <INITIAL> "]"         => (Tokens.RBRACK (pos yypos, pos yypos + size yytext));
-<INITIAL> "{"         => (Tokens.LBRACE (pos yypos, pos yypos + size yytext));
-<INITIAL> "}"         => (Tokens.RBRACE (pos yypos, pos yypos + size yytext));
+<INITIAL> "{"         => (enterBrace ();
+                          Tokens.LBRACE (pos yypos, pos yypos + size yytext));
+<INITIAL> "}"         => (exitBrace ();
+                          Tokens.RBRACE (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "->"        => (Tokens.ARROW (pos yypos, pos yypos + size yytext));
 <INITIAL> "=>"        => (Tokens.DARROW (pos yypos, pos yypos + size yytext));
diff --git a/src/list_util.sig b/src/list_util.sig
index b4ea338c..e0629c5d 100644
--- a/src/list_util.sig
+++ b/src/list_util.sig
@@ -27,6 +27,8 @@
 
 signature LIST_UTIL = sig
 
+    val mapConcat : ('a -> 'b list) -> 'a list -> 'b list
+
     val mapfold : ('data, 'state, 'abort) Search.mapfolder
                   -> ('data list, 'state, 'abort) Search.mapfolder
     val mapfoldB : ('context * 'data -> 'context * ('state -> ('data * 'state, 'abort) Search.result))
diff --git a/src/list_util.sml b/src/list_util.sml
index 7f87b87e..fff3e78e 100644
--- a/src/list_util.sml
+++ b/src/list_util.sml
@@ -29,6 +29,16 @@ structure ListUtil :> LIST_UTIL = struct
 
 structure S = Search
 
+fun mapConcat f =
+    let
+        fun mc acc ls =
+            case ls of
+                [] => rev acc
+              | h :: t => mc (List.revAppend (f h, acc)) t
+    in
+        mc []
+    end
+
 fun mapfold f =
     let
         fun mf ls s =
diff --git a/src/monoize.sml b/src/monoize.sml
index 5f5db692..2e21a2bf 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -192,6 +192,8 @@ fun monoExp env (all as (e, loc)) =
           | L.EField (e, x, _) => (L'.EField (monoExp env e, monoName env x), loc)
           | L.EFold _ => poly ()
           | L.EWrite e => (L'.EWrite (monoExp env e), loc)
+
+          | L.EClosure _ => raise Fail "Monoize EClosure"
     end
 
 fun monoDecl env (all as (d, loc)) =
diff --git a/src/sources b/src/sources
index 7faec26b..2453e1c5 100644
--- a/src/sources
+++ b/src/sources
@@ -75,6 +75,9 @@ reduce.sml
 shake.sig
 shake.sml
 
+tag.sig
+tag.sml
+
 mono.sml
 
 mono_util.sig
diff --git a/src/tag.sig b/src/tag.sig
new file mode 100644
index 00000000..c19a353e
--- /dev/null
+++ b/src/tag.sig
@@ -0,0 +1,32 @@
+(* Copyright (c) 2008, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+signature TAG = sig
+
+    val tag : Core.file -> Core.file
+
+end
diff --git a/src/tag.sml b/src/tag.sml
new file mode 100644
index 00000000..a244c294
--- /dev/null
+++ b/src/tag.sml
@@ -0,0 +1,174 @@
+(* Copyright (c) 2008, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+structure Tag :> TAG = struct
+
+open Core
+
+structure U = CoreUtil
+structure E = CoreEnv
+
+structure IM = IntBinaryMap
+
+fun kind (k, s) = (k, s)
+fun con (c, s) = (c, s)
+
+fun exp (e, s) =
+    case e of
+        EApp (
+        (EApp (
+         (EApp (
+          (ECApp (
+           (ECApp (
+            (ECApp (
+             (ECApp (
+              (EFfi ("Basis", "tag"),
+               loc), given), _), absent), _), outer), _), inner), _),
+          attrs), _),
+         tag), _),
+        xml) =>
+        (case attrs of
+             (ERecord xets, _) =>
+             let
+                 val (xets, s) =
+                     ListUtil.foldlMap (fn ((x, e, t), (count, tags, newTags)) =>
+                                           case x of
+                                               (CName "Link", _) =>
+                                               let
+                                                   fun unravel (e, _) =
+                                                       case e of
+                                                           ENamed n => (n, [])
+                                                         | EApp (e1, e2) =>
+                                                           let
+                                                               val (n, es) = unravel e1
+                                                           in
+                                                               (n, es @ [e2])
+                                                           end
+                                                         | _ => (ErrorMsg.errorAt loc "Invalid link expression";
+                                                                 (0, []))
+
+                                                   val (f, args) = unravel e
+
+                                                   val (cn, count, tags, newTags) =
+                                                       case IM.find (tags, f) of
+                                                           NONE =>
+                                                           (count, count + 1, IM.insert (tags, f, count),
+                                                            (f, count) :: newTags)
+                                                         | SOME cn => (cn, count, tags, newTags)
+
+                                                   val e = (EClosure (cn, args), loc)
+                                                   val t = (CFfi ("Basis", "string"), loc)
+                                               in
+                                                   ((x, e, t),
+                                                    (count, tags, newTags))
+                                               end
+                                             | _ => ((x, e, t), (count, tags, newTags)))
+                     s xets
+             in
+                 (EApp (
+                  (EApp (
+                   (EApp (
+                    (ECApp (
+                     (ECApp (
+                      (ECApp (
+                       (ECApp (
+                        (EFfi ("Basis", "tag"),
+                         loc), given), loc), absent), loc), outer), loc), inner), loc),
+                    (ERecord xets, loc)), loc),
+                   tag), loc),
+                  xml), s)
+             end
+           | _ => (ErrorMsg.errorAt loc "Attribute record is too complex";
+                   (e, s)))
+
+      | _ => (e, s)
+
+fun decl (d, s) = (d, s)
+
+fun tag file =
+    let
+        val count = foldl (fn ((d, _), count) =>
+                              case d of
+                                  DCon (_, n, _, _) => Int.max (n, count)
+                                | DVal (_, n, _, _, _) => Int.max (n, count)
+                                | DExport _ => count) 0 file
+
+        fun doDecl (d as (d', loc), (env, count, tags)) =
+            let
+                val (d, (count, tags, newTags)) =
+                    U.Decl.foldMap {kind = kind,
+                                    con = con,
+                                    exp = exp,
+                                    decl = decl}
+                                   (count, tags, []) d
+
+                val env = E.declBinds env d
+
+                val newDs = ListUtil.mapConcat
+                                (fn (f, cn) =>
+                                    let
+                                        fun unravel (all as (t, _)) =
+                                            case t of
+                                                TFun (dom, ran) =>
+                                                let
+                                                    val (args, result) = unravel ran
+                                                in
+                                                    (dom :: args, result)
+                                                end
+                                              | _ => ([], all)
+
+                                        val (fnam, t, _, tag) = E.lookupENamed env f
+                                        val (args, result) = unravel t
+
+                                        val (app, _) = foldl (fn (t, (app, n)) =>
+                                                                 ((EApp (app, (ERel n, loc)), loc),
+                                                                  n - 1))
+                                                             ((ENamed f, loc), length args - 1) args
+                                        val body = (EWrite app, loc)
+                                        val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
+                                        val (abs, _, t) = foldr (fn (t, (abs, n, rest)) =>
+                                                                    ((EAbs ("x" ^ Int.toString n,
+                                                                            t,
+                                                                            rest,
+                                                                            abs), loc),
+                                                                     n + 1,
+                                                                     (TFun (t, rest), loc)))
+                                                                (body, 0, unit) args
+                                    in
+                                        [(DVal ("wrap_" ^ fnam, cn, t, abs, tag), loc),
+                                         (DExport cn, loc)]
+                                    end) newTags
+            in
+                (newDs @ [d], (env, count, tags))
+            end
+
+        val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count, IM.empty) file
+    in
+        file
+    end
+
+end