Factor out [Monoize.Fm] to make it accessible to [Sqlcache].

4 files changed, 148 insertions, 126 deletions

diff --git a/src/mono_fm.sig b/src/mono_fm.sig
new file mode 100644
index 00000000..a72a5da7
--- /dev/null
+++ b/src/mono_fm.sig
@@ -0,0 +1,22 @@
+signature MONO_FM = sig
+    type t
+
+    type vr = string * int * Mono.typ * Mono.exp * string
+
+    datatype foo_kind =
+             Attr
+             | Url
+
+    val empty : int -> t
+
+    val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int
+    val lookupList : t -> foo_kind -> Mono.typ -> (int -> t -> vr * t) -> t * int
+    val enter : t -> t
+    val decls : t -> Mono.decl list
+
+    val freshName : t -> int * t
+
+    (* TODO: don't expose raw references if possible. *)
+    val nextPvar : int ref
+    val postMonoize : t ref
+end
diff --git a/src/mono_fm.sml b/src/mono_fm.sml
new file mode 100644
index 00000000..d7e9e001
--- /dev/null
+++ b/src/mono_fm.sml
@@ -0,0 +1,115 @@
+(* TODO: better name than "fm"? *)
+structure MonoFm : MONO_FM = struct
+
+open Mono
+
+type vr = string * int * typ * exp * string
+
+datatype foo_kind =
+         Attr
+       | Url
+
+structure IM = IntBinaryMap
+
+structure M = BinaryMapFn(struct
+                          type ord_key = foo_kind
+                          fun compare x =
+                              case x of
+                                  (Attr, Attr) => EQUAL
+                                | (Attr, _) => LESS
+                                | (_, Attr) => GREATER
+
+                                | (Url, Url) => EQUAL
+                          end)
+
+structure TM = BinaryMapFn(struct
+                           type ord_key = typ
+                           val compare = MonoUtil.Typ.compare
+                           end)
+
+type t = {
+     count : int,
+     map : int IM.map M.map,
+     listMap : int TM.map M.map,
+     decls : vr list
+}
+
+val nextPvar = ref 0
+
+fun empty count = {
+    count = count,
+    map = M.empty,
+    listMap = M.empty,
+    decls = []
+}
+
+fun chooseNext count =
+    let
+        val n = !nextPvar
+    in
+        if count < n then
+            (count, count+1)
+        else
+            (nextPvar := n + 1;
+             (n, n+1))
+    end
+
+fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
+fun freshName {count, map, listMap, decls} =
+    let
+        val (next, count) = chooseNext count
+    in
+        (next, {count = count , map = map, listMap = listMap, decls = decls})
+    end
+fun decls ({decls, ...} : t) =
+    case decls of
+        [] => []
+      | _ => [(DValRec decls, ErrorMsg.dummySpan)]
+
+fun lookup (t as {count, map, listMap, decls}) k n thunk =
+    let
+        val im = Option.getOpt (M.find (map, k), IM.empty)
+    in
+        case IM.find (im, n) of
+            NONE =>
+            let
+                val n' = count
+                val (d, {count, map, listMap, decls}) =
+                    thunk count {count = count + 1,
+                                 map = M.insert (map, k, IM.insert (im, n, n')),
+                                 listMap = listMap,
+                                 decls = decls}
+            in
+                ({count = count,
+                  map = map,
+                  listMap = listMap,
+                  decls = d :: decls}, n')
+            end
+          | SOME n' => (t, n')
+    end
+
+fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
+    let
+        val tm = Option.getOpt (M.find (listMap, k), TM.empty)
+    in
+        case TM.find (tm, tp) of
+            NONE =>
+            let
+                val n' = count
+                val (d, {count, map, listMap, decls}) =
+                    thunk count {count = count + 1,
+                                 map = map,
+                                 listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
+                                 decls = decls}
+            in
+                ({count = count,
+                  map = map,
+                  listMap = listMap,
+                  decls = d :: decls}, n')
+            end
+          | SOME n' => (t, n')
+    end
+
+val postMonoize : t ref = ref (empty 0)
+
+end
diff --git a/src/monoize.sml b/src/monoize.sml
index d8c4d276..4bd3aff2 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -50,7 +50,7 @@ structure RM = BinaryMapFn(struct
                                                                         (L'.TRecord r2, E.dummySpan))
                            end)
 
-val nextPvar = ref 0
+val nextPvar = MonoFm.nextPvar
 val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map)
 val pvarDefs = ref ([] : (string * int * (string * int * L'.typ option) list) list)
 val pvarOldDefs = ref ([] : (int * (string * int * L.con option) list) list)
@@ -374,131 +374,12 @@ fun monoType env =
 
 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
 
-structure IM = IntBinaryMap
-
-datatype foo_kind =
-         Attr
-       | Url
+structure Fm = MonoFm
 
 fun fk2s fk =
     case fk of
-        Attr => "attr"
-      | Url => "url"
-
-type vr = string * int * L'.typ * L'.exp * string
-
-structure Fm :> sig
-    type t
-
-    val empty : int -> t
-
-    val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int
-    val lookupList : t -> foo_kind -> L'.typ -> (int -> t -> vr * t) -> t * int
-    val enter : t -> t
-    val decls : t -> L'.decl list
-
-    val freshName : t -> int * t
-end = struct
-
-structure M = BinaryMapFn(struct
-                          type ord_key = foo_kind
-                          fun compare x =
-                              case x of
-                                  (Attr, Attr) => EQUAL
-                                | (Attr, _) => LESS
-                                | (_, Attr) => GREATER
-
-                                | (Url, Url) => EQUAL
-                          end)
-
-structure TM = BinaryMapFn(struct
-                           type ord_key = L'.typ
-                           val compare = MonoUtil.Typ.compare
-                           end)
-
-type t = {
-     count : int,
-     map : int IM.map M.map,
-     listMap : int TM.map M.map,
-     decls : vr list
-}
-
-fun empty count = {
-    count = count,
-    map = M.empty,
-    listMap = M.empty,
-    decls = []
-}
-
-fun chooseNext count =
-    let
-        val n = !nextPvar
-    in
-        if count < n then
-            (count, count+1)
-        else
-            (nextPvar := n + 1;
-             (n, n+1))
-    end
-
-fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
-fun freshName {count, map, listMap, decls} =
-    let
-        val (next, count) = chooseNext count
-    in
-        (next, {count = count , map = map, listMap = listMap, decls = decls})
-    end
-fun decls ({decls, ...} : t) =
-    case decls of
-        [] => []
-      | _ => [(L'.DValRec decls, ErrorMsg.dummySpan)]
-
-fun lookup (t as {count, map, listMap, decls}) k n thunk =
-    let
-        val im = Option.getOpt (M.find (map, k), IM.empty)
-    in
-        case IM.find (im, n) of
-            NONE =>
-            let
-                val n' = count
-                val (d, {count, map, listMap, decls}) =
-                    thunk count {count = count + 1,
-                                 map = M.insert (map, k, IM.insert (im, n, n')),
-                                 listMap = listMap,
-                                 decls = decls}
-            in
-                ({count = count,
-                  map = map,
-                  listMap = listMap,
-                  decls = d :: decls}, n')
-            end
-          | SOME n' => (t, n')
-    end
-
-fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
-    let
-        val tm = Option.getOpt (M.find (listMap, k), TM.empty)
-    in
-        case TM.find (tm, tp) of
-            NONE =>
-            let
-                val n' = count
-                val (d, {count, map, listMap, decls}) =
-                    thunk count {count = count + 1,
-                                 map = map,
-                                 listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
-                                 decls = decls}
-            in
-                ({count = count,
-                  map = map,
-                  listMap = listMap,
-                  decls = d :: decls}, n')
-            end
-          | SOME n' => (t, n')
-    end
-
-end
-
+        Fm.Attr => "attr"
+      | Fm.Url => "url"
 
 fun capitalize s =
     if s = "" then
@@ -677,8 +558,8 @@ fun fooifyExp fk env =
         fooify
     end
 
-val attrifyExp = fooifyExp Attr
-val urlifyExp = fooifyExp Url
+val attrifyExp = fooifyExp Fm.Attr
+val urlifyExp = fooifyExp Fm.Url
 
 val urlifiedUnit =
     let
@@ -4738,7 +4619,7 @@ fun monoize env file =
         val mname = CoreUtil.File.maxName file + 1
         val () = nextPvar := mname
 
-        val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
+        val (_, fm, ds) = List.foldl (fn (d, (env, fm, ds)) =>
                                         case #1 d of
                                             L.DDatabase s =>
                                             let
@@ -4786,6 +4667,7 @@ fun monoize env file =
         pvars := RM.empty;
         pvarDefs := [];
         pvarOldDefs := [];
+        Fm.postMonoize := fm;
         (rev ds, [])
     end
 
diff --git a/src/sources b/src/sources
index f0914bdf..e6a361ce 100644
--- a/src/sources
+++ b/src/sources
@@ -168,6 +168,9 @@ $(SRC)/mono_env.sml
 $(SRC)/mono_print.sig
 $(SRC)/mono_print.sml
 
+$(SRC)/mono_fm.sig
+$(SRC)/mono_fm.sml
+
 $(SRC)/sql.sig
 $(SRC)/sql.sml