1 files changed, 115 insertions, 0 deletions
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