Mercurial > urweb

annotate src/mono_fm.sml @ 2253:d665925acff8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Factor out [Monoize.Fm] to make it accessible to [Sqlcache].
author Ziv Scully <ziv@mit.edu>
date Mon, 21 Sep 2015 14:54:07 -0400
parents
children
rev   line source
ziv@2253 1 (* TODO: better name than "fm"? *)
ziv@2253 2 structure MonoFm : MONO_FM = struct
ziv@2253 3
ziv@2253 4 open Mono
ziv@2253 5
ziv@2253 6 type vr = string * int * typ * exp * string
ziv@2253 7
ziv@2253 8 datatype foo_kind =
ziv@2253 9 Attr
ziv@2253 10 | Url
ziv@2253 11
ziv@2253 12 structure IM = IntBinaryMap
ziv@2253 13
ziv@2253 14 structure M = BinaryMapFn(struct
ziv@2253 15 type ord_key = foo_kind
ziv@2253 16 fun compare x =
ziv@2253 17 case x of
ziv@2253 18 (Attr, Attr) => EQUAL
ziv@2253 19 | (Attr, _) => LESS
ziv@2253 20 | (_, Attr) => GREATER
ziv@2253 21
ziv@2253 22 | (Url, Url) => EQUAL
ziv@2253 23 end)
ziv@2253 24
ziv@2253 25 structure TM = BinaryMapFn(struct
ziv@2253 26 type ord_key = typ
ziv@2253 27 val compare = MonoUtil.Typ.compare
ziv@2253 28 end)
ziv@2253 29
ziv@2253 30 type t = {
ziv@2253 31 count : int,
ziv@2253 32 map : int IM.map M.map,
ziv@2253 33 listMap : int TM.map M.map,
ziv@2253 34 decls : vr list
ziv@2253 35 }
ziv@2253 36
ziv@2253 37 val nextPvar = ref 0
ziv@2253 38
ziv@2253 39 fun empty count = {
ziv@2253 40 count = count,
ziv@2253 41 map = M.empty,
ziv@2253 42 listMap = M.empty,
ziv@2253 43 decls = []
ziv@2253 44 }
ziv@2253 45
ziv@2253 46 fun chooseNext count =
ziv@2253 47 let
ziv@2253 48 val n = !nextPvar
ziv@2253 49 in
ziv@2253 50 if count < n then
ziv@2253 51 (count, count+1)
ziv@2253 52 else
ziv@2253 53 (nextPvar := n + 1;
ziv@2253 54 (n, n+1))
ziv@2253 55 end
ziv@2253 56
ziv@2253 57 fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
ziv@2253 58 fun freshName {count, map, listMap, decls} =
ziv@2253 59 let
ziv@2253 60 val (next, count) = chooseNext count
ziv@2253 61 in
ziv@2253 62 (next, {count = count , map = map, listMap = listMap, decls = decls})
ziv@2253 63 end
ziv@2253 64 fun decls ({decls, ...} : t) =
ziv@2253 65 case decls of
ziv@2253 66 [] => []
ziv@2253 67 | _ => [(DValRec decls, ErrorMsg.dummySpan)]
ziv@2253 68
ziv@2253 69 fun lookup (t as {count, map, listMap, decls}) k n thunk =
ziv@2253 70 let
ziv@2253 71 val im = Option.getOpt (M.find (map, k), IM.empty)
ziv@2253 72 in
ziv@2253 73 case IM.find (im, n) of
ziv@2253 74 NONE =>
ziv@2253 75 let
ziv@2253 76 val n' = count
ziv@2253 77 val (d, {count, map, listMap, decls}) =
ziv@2253 78 thunk count {count = count + 1,
ziv@2253 79 map = M.insert (map, k, IM.insert (im, n, n')),
ziv@2253 80 listMap = listMap,
ziv@2253 81 decls = decls}
ziv@2253 82 in
ziv@2253 83 ({count = count,
ziv@2253 84 map = map,
ziv@2253 85 listMap = listMap,
ziv@2253 86 decls = d :: decls}, n')
ziv@2253 87 end
ziv@2253 88 | SOME n' => (t, n')
ziv@2253 89 end
ziv@2253 90
ziv@2253 91 fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
ziv@2253 92 let
ziv@2253 93 val tm = Option.getOpt (M.find (listMap, k), TM.empty)
ziv@2253 94 in
ziv@2253 95 case TM.find (tm, tp) of
ziv@2253 96 NONE =>
ziv@2253 97 let
ziv@2253 98 val n' = count
ziv@2253 99 val (d, {count, map, listMap, decls}) =
ziv@2253 100 thunk count {count = count + 1,
ziv@2253 101 map = map,
ziv@2253 102 listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
ziv@2253 103 decls = decls}
ziv@2253 104 in
ziv@2253 105 ({count = count,
ziv@2253 106 map = map,
ziv@2253 107 listMap = listMap,
ziv@2253 108 decls = d :: decls}, n')
ziv@2253 109 end
ziv@2253 110 | SOME n' => (t, n')
ziv@2253 111 end
ziv@2253 112
ziv@2253 113 val postMonoize : t ref = ref (empty 0)
ziv@2253 114
ziv@2253 115 end