ziv@2253: (* TODO: better name than "fm"? *)
ziv@2253: structure MonoFm : MONO_FM = struct
ziv@2253: 
ziv@2253: open Mono
ziv@2253: 
ziv@2253: type vr = string * int * typ * exp * string
ziv@2253: 
ziv@2253: datatype foo_kind =
ziv@2253:          Attr
ziv@2253:        | Url
ziv@2253: 
ziv@2253: structure IM = IntBinaryMap
ziv@2253: 
ziv@2253: structure M = BinaryMapFn(struct
ziv@2253:                           type ord_key = foo_kind
ziv@2253:                           fun compare x =
ziv@2253:                               case x of
ziv@2253:                                   (Attr, Attr) => EQUAL
ziv@2253:                                 | (Attr, _) => LESS
ziv@2253:                                 | (_, Attr) => GREATER
ziv@2253: 
ziv@2253:                                 | (Url, Url) => EQUAL
ziv@2253:                           end)
ziv@2253: 
ziv@2253: structure TM = BinaryMapFn(struct
ziv@2253:                            type ord_key = typ
ziv@2253:                            val compare = MonoUtil.Typ.compare
ziv@2253:                            end)
ziv@2253: 
ziv@2253: type t = {
ziv@2253:      count : int,
ziv@2253:      map : int IM.map M.map,
ziv@2253:      listMap : int TM.map M.map,
ziv@2253:      decls : vr list
ziv@2253: }
ziv@2253: 
ziv@2253: val nextPvar = ref 0
ziv@2253: 
ziv@2253: fun empty count = {
ziv@2253:     count = count,
ziv@2253:     map = M.empty,
ziv@2253:     listMap = M.empty,
ziv@2253:     decls = []
ziv@2253: }
ziv@2253: 
ziv@2253: fun chooseNext count =
ziv@2253:     let
ziv@2253:         val n = !nextPvar
ziv@2253:     in
ziv@2253:         if count < n then
ziv@2253:             (count, count+1)
ziv@2253:         else
ziv@2253:             (nextPvar := n + 1;
ziv@2253:              (n, n+1))
ziv@2253:     end
ziv@2253: 
ziv@2253: fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
ziv@2253: fun freshName {count, map, listMap, decls} =
ziv@2253:     let
ziv@2253:         val (next, count) = chooseNext count
ziv@2253:     in
ziv@2253:         (next, {count = count , map = map, listMap = listMap, decls = decls})
ziv@2253:     end
ziv@2253: fun decls ({decls, ...} : t) =
ziv@2253:     case decls of
ziv@2253:         [] => []
ziv@2253:       | _ => [(DValRec decls, ErrorMsg.dummySpan)]
ziv@2253: 
ziv@2253: fun lookup (t as {count, map, listMap, decls}) k n thunk =
ziv@2253:     let
ziv@2253:         val im = Option.getOpt (M.find (map, k), IM.empty)
ziv@2253:     in
ziv@2253:         case IM.find (im, n) of
ziv@2253:             NONE =>
ziv@2253:             let
ziv@2253:                 val n' = count
ziv@2253:                 val (d, {count, map, listMap, decls}) =
ziv@2253:                     thunk count {count = count + 1,
ziv@2253:                                  map = M.insert (map, k, IM.insert (im, n, n')),
ziv@2253:                                  listMap = listMap,
ziv@2253:                                  decls = decls}
ziv@2253:             in
ziv@2253:                 ({count = count,
ziv@2253:                   map = map,
ziv@2253:                   listMap = listMap,
ziv@2253:                   decls = d :: decls}, n')
ziv@2253:             end
ziv@2253:           | SOME n' => (t, n')
ziv@2253:     end
ziv@2253: 
ziv@2253: fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
ziv@2253:     let
ziv@2253:         val tm = Option.getOpt (M.find (listMap, k), TM.empty)
ziv@2253:     in
ziv@2253:         case TM.find (tm, tp) of
ziv@2253:             NONE =>
ziv@2253:             let
ziv@2253:                 val n' = count
ziv@2253:                 val (d, {count, map, listMap, decls}) =
ziv@2253:                     thunk count {count = count + 1,
ziv@2253:                                  map = map,
ziv@2253:                                  listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
ziv@2253:                                  decls = decls}
ziv@2253:             in
ziv@2253:                 ({count = count,
ziv@2253:                   map = map,
ziv@2253:                   listMap = listMap,
ziv@2253:                   decls = d :: decls}, n')
ziv@2253:             end
ziv@2253:           | SOME n' => (t, n')
ziv@2253:     end
ziv@2253: 
ziv@2253: val postMonoize : t ref = ref (empty 0)
ziv@2253: 
ziv@2253: end