Mercurial > urweb

annotate src/mono_fooify.sml @ 2254:44ae2254f8fb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Factor out urlification.
author Ziv Scully <ziv@mit.edu>
date Mon, 21 Sep 2015 16:07:35 -0400
parents
children 6f2ea4ed573a
rev   line source
ziv@2254 1 structure MonoFooify :> MONO_FOOIFY = struct
ziv@2254 2
ziv@2254 3 open Mono
ziv@2254 4
ziv@2254 5 datatype foo_kind =
ziv@2254 6 Attr
ziv@2254 7 | Url
ziv@2254 8
ziv@2254 9 val nextPvar = ref 0
ziv@2254 10 val pvarDefs = ref ([] : (string * int * (string * int * typ option) list) list)
ziv@2254 11
ziv@2254 12 structure Fm = struct
ziv@2254 13
ziv@2254 14 type vr = string * int * typ * exp * string
ziv@2254 15
ziv@2254 16 structure IM = IntBinaryMap
ziv@2254 17
ziv@2254 18 structure M = BinaryMapFn(struct
ziv@2254 19 type ord_key = foo_kind
ziv@2254 20 fun compare x =
ziv@2254 21 case x of
ziv@2254 22 (Attr, Attr) => EQUAL
ziv@2254 23 | (Attr, _) => LESS
ziv@2254 24 | (_, Attr) => GREATER
ziv@2254 25
ziv@2254 26 | (Url, Url) => EQUAL
ziv@2254 27 end)
ziv@2254 28
ziv@2254 29 structure TM = BinaryMapFn(struct
ziv@2254 30 type ord_key = typ
ziv@2254 31 val compare = MonoUtil.Typ.compare
ziv@2254 32 end)
ziv@2254 33
ziv@2254 34 type t = {
ziv@2254 35 count : int,
ziv@2254 36 map : int IM.map M.map,
ziv@2254 37 listMap : int TM.map M.map,
ziv@2254 38 decls : vr list
ziv@2254 39 }
ziv@2254 40
ziv@2254 41 fun empty count = {
ziv@2254 42 count = count,
ziv@2254 43 map = M.empty,
ziv@2254 44 listMap = M.empty,
ziv@2254 45 decls = []
ziv@2254 46 }
ziv@2254 47
ziv@2254 48 fun chooseNext count =
ziv@2254 49 let
ziv@2254 50 val n = !nextPvar
ziv@2254 51 in
ziv@2254 52 if count < n then
ziv@2254 53 (count, count+1)
ziv@2254 54 else
ziv@2254 55 (nextPvar := n + 1;
ziv@2254 56 (n, n+1))
ziv@2254 57 end
ziv@2254 58
ziv@2254 59 fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
ziv@2254 60 fun freshName {count, map, listMap, decls} =
ziv@2254 61 let
ziv@2254 62 val (next, count) = chooseNext count
ziv@2254 63 in
ziv@2254 64 (next, {count = count , map = map, listMap = listMap, decls = decls})
ziv@2254 65 end
ziv@2254 66 fun decls ({decls, ...} : t) =
ziv@2254 67 case decls of
ziv@2254 68 [] => []
ziv@2254 69 | _ => [(DValRec decls, ErrorMsg.dummySpan)]
ziv@2254 70
ziv@2254 71 fun lookup (t as {count, map, listMap, decls}) k n thunk =
ziv@2254 72 let
ziv@2254 73 val im = Option.getOpt (M.find (map, k), IM.empty)
ziv@2254 74 in
ziv@2254 75 case IM.find (im, n) of
ziv@2254 76 NONE =>
ziv@2254 77 let
ziv@2254 78 val n' = count
ziv@2254 79 val (d, {count, map, listMap, decls}) =
ziv@2254 80 thunk count {count = count + 1,
ziv@2254 81 map = M.insert (map, k, IM.insert (im, n, n')),
ziv@2254 82 listMap = listMap,
ziv@2254 83 decls = decls}
ziv@2254 84 in
ziv@2254 85 ({count = count,
ziv@2254 86 map = map,
ziv@2254 87 listMap = listMap,
ziv@2254 88 decls = d :: decls}, n')
ziv@2254 89 end
ziv@2254 90 | SOME n' => (t, n')
ziv@2254 91 end
ziv@2254 92
ziv@2254 93 fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
ziv@2254 94 let
ziv@2254 95 val tm = Option.getOpt (M.find (listMap, k), TM.empty)
ziv@2254 96 in
ziv@2254 97 case TM.find (tm, tp) of
ziv@2254 98 NONE =>
ziv@2254 99 let
ziv@2254 100 val n' = count
ziv@2254 101 val (d, {count, map, listMap, decls}) =
ziv@2254 102 thunk count {count = count + 1,
ziv@2254 103 map = map,
ziv@2254 104 listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
ziv@2254 105 decls = decls}
ziv@2254 106 in
ziv@2254 107 ({count = count,
ziv@2254 108 map = map,
ziv@2254 109 listMap = listMap,
ziv@2254 110 decls = d :: decls}, n')
ziv@2254 111 end
ziv@2254 112 | SOME n' => (t, n')
ziv@2254 113 end
ziv@2254 114
ziv@2254 115 (* Has to be set at the end of [Monoize]. *)
ziv@2254 116 val canonical = ref (empty 0 : t)
ziv@2254 117
ziv@2254 118 end
ziv@2254 119
ziv@2254 120 fun fk2s fk =
ziv@2254 121 case fk of
ziv@2254 122 Attr => "attr"
ziv@2254 123 | Url => "url"
ziv@2254 124
ziv@2254 125 fun capitalize s =
ziv@2254 126 if s = "" then
ziv@2254 127 s
ziv@2254 128 else
ziv@2254 129 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
ziv@2254 130
ziv@2254 131 structure E = ErrorMsg
ziv@2254 132
ziv@2254 133 val dummyExp = (EPrim (Prim.Int 0), E.dummySpan)
ziv@2254 134
ziv@2254 135 fun fooifyExp fk lookupENamed lookupDatatype =
ziv@2254 136 let
ziv@2254 137 fun fooify fm (e, tAll as (t, loc)) =
ziv@2254 138 case #1 e of
ziv@2254 139 EClosure (fnam, [(ERecord [], _)]) =>
ziv@2254 140 let
ziv@2254 141 val (_, s) = lookupENamed fnam
ziv@2254 142 in
ziv@2254 143 ((EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
ziv@2254 144 end
ziv@2254 145 | EClosure (fnam, args) =>
ziv@2254 146 let
ziv@2254 147 val (ft, s) = lookupENamed fnam
ziv@2254 148 fun attrify (args, ft, e, fm) =
ziv@2254 149 case (args, ft) of
ziv@2254 150 ([], _) => (e, fm)
ziv@2254 151 | (arg :: args, (TFun (t, ft), _)) =>
ziv@2254 152 let
ziv@2254 153 val (arg', fm) = fooify fm (arg, t)
ziv@2254 154 in
ziv@2254 155 attrify (args, ft,
ziv@2254 156 (EStrcat (e,
ziv@2254 157 (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc),
ziv@2254 158 arg'), loc)), loc),
ziv@2254 159 fm)
ziv@2254 160 end
ziv@2254 161 | _ => (E.errorAt loc "Type mismatch encoding attribute";
ziv@2254 162 (e, fm))
ziv@2254 163 in
ziv@2254 164 attrify (args, ft, (EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
ziv@2254 165 end
ziv@2254 166 | _ =>
ziv@2254 167 case t of
ziv@2254 168 TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
ziv@2254 169 | TFfi (m, x) => ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)
ziv@2254 170
ziv@2254 171 | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
ziv@2254 172 | TRecord ((x, t) :: xts) =>
ziv@2254 173 let
ziv@2254 174 val (se, fm) = fooify fm ((EField (e, x), loc), t)
ziv@2254 175 in
ziv@2254 176 foldl (fn ((x, t), (se, fm)) =>
ziv@2254 177 let
ziv@2254 178 val (se', fm) = fooify fm ((EField (e, x), loc), t)
ziv@2254 179 in
ziv@2254 180 ((EStrcat (se,
ziv@2254 181 (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc),
ziv@2254 182 se'), loc)), loc),
ziv@2254 183 fm)
ziv@2254 184 end) (se, fm) xts
ziv@2254 185 end
ziv@2254 186
ziv@2254 187 | TDatatype (i, ref (dk, _)) =>
ziv@2254 188 let
ziv@2254 189 fun makeDecl n fm =
ziv@2254 190 let
ziv@2254 191 val (x, xncs) =
ziv@2254 192 case ListUtil.search (fn (x, i', xncs) =>
ziv@2254 193 if i' = i then
ziv@2254 194 SOME (x, xncs)
ziv@2254 195 else
ziv@2254 196 NONE) (!pvarDefs) of
ziv@2254 197 NONE => lookupDatatype i
ziv@2254 198 | SOME v => v
ziv@2254 199
ziv@2254 200 val (branches, fm) =
ziv@2254 201 ListUtil.foldlMap
ziv@2254 202 (fn ((x, n, to), fm) =>
ziv@2254 203 case to of
ziv@2254 204 NONE =>
ziv@2254 205 (((PCon (dk, PConVar n, NONE), loc),
ziv@2254 206 (EPrim (Prim.String (Prim.Normal, x)), loc)),
ziv@2254 207 fm)
ziv@2254 208 | SOME t =>
ziv@2254 209 let
ziv@2254 210 val (arg, fm) = fooify fm ((ERel 0, loc), t)
ziv@2254 211 in
ziv@2254 212 (((PCon (dk, PConVar n, SOME (PVar ("a", t), loc)), loc),
ziv@2254 213 (EStrcat ((EPrim (Prim.String (Prim.Normal, x ^ "/")), loc),
ziv@2254 214 arg), loc)),
ziv@2254 215 fm)
ziv@2254 216 end)
ziv@2254 217 fm xncs
ziv@2254 218
ziv@2254 219 val dom = tAll
ziv@2254 220 val ran = (TFfi ("Basis", "string"), loc)
ziv@2254 221 in
ziv@2254 222 ((fk2s fk ^ "ify_" ^ x,
ziv@2254 223 n,
ziv@2254 224 (TFun (dom, ran), loc),
ziv@2254 225 (EAbs ("x",
ziv@2254 226 dom,
ziv@2254 227 ran,
ziv@2254 228 (ECase ((ERel 0, loc),
ziv@2254 229 branches,
ziv@2254 230 {disc = dom,
ziv@2254 231 result = ran}), loc)), loc),
ziv@2254 232 ""),
ziv@2254 233 fm)
ziv@2254 234 end
ziv@2254 235
ziv@2254 236 val (fm, n) = Fm.lookup fm fk i makeDecl
ziv@2254 237 in
ziv@2254 238 ((EApp ((ENamed n, loc), e), loc), fm)
ziv@2254 239 end
ziv@2254 240
ziv@2254 241 | TOption t =>
ziv@2254 242 let
ziv@2254 243 val (body, fm) = fooify fm ((ERel 0, loc), t)
ziv@2254 244 in
ziv@2254 245 ((ECase (e,
ziv@2254 246 [((PNone t, loc),
ziv@2254 247 (EPrim (Prim.String (Prim.Normal, "None")), loc)),
ziv@2254 248
ziv@2254 249 ((PSome (t, (PVar ("x", t), loc)), loc),
ziv@2254 250 (EStrcat ((EPrim (Prim.String (Prim.Normal, "Some/")), loc),
ziv@2254 251 body), loc))],
ziv@2254 252 {disc = tAll,
ziv@2254 253 result = (TFfi ("Basis", "string"), loc)}), loc),
ziv@2254 254 fm)
ziv@2254 255 end
ziv@2254 256
ziv@2254 257 | TList t =>
ziv@2254 258 let
ziv@2254 259 fun makeDecl n fm =
ziv@2254 260 let
ziv@2254 261 val rt = (TRecord [("1", t), ("2", (TList t, loc))], loc)
ziv@2254 262 val (arg, fm) = fooify fm ((ERel 0, loc), rt)
ziv@2254 263
ziv@2254 264 val branches = [((PNone rt, loc),
ziv@2254 265 (EPrim (Prim.String (Prim.Normal, "Nil")), loc)),
ziv@2254 266 ((PSome (rt, (PVar ("a", rt), loc)), loc),
ziv@2254 267 (EStrcat ((EPrim (Prim.String (Prim.Normal, "Cons/")), loc),
ziv@2254 268 arg), loc))]
ziv@2254 269
ziv@2254 270 val dom = tAll
ziv@2254 271 val ran = (TFfi ("Basis", "string"), loc)
ziv@2254 272 in
ziv@2254 273 ((fk2s fk ^ "ify_list",
ziv@2254 274 n,
ziv@2254 275 (TFun (dom, ran), loc),
ziv@2254 276 (EAbs ("x",
ziv@2254 277 dom,
ziv@2254 278 ran,
ziv@2254 279 (ECase ((ERel 0, loc),
ziv@2254 280 branches,
ziv@2254 281 {disc = dom,
ziv@2254 282 result = ran}), loc)), loc),
ziv@2254 283 ""),
ziv@2254 284 fm)
ziv@2254 285 end
ziv@2254 286
ziv@2254 287 val (fm, n) = Fm.lookupList fm fk t makeDecl
ziv@2254 288 in
ziv@2254 289 ((EApp ((ENamed n, loc), e), loc), fm)
ziv@2254 290 end
ziv@2254 291
ziv@2254 292 | _ => (E.errorAt loc "Don't know how to encode attribute/URL type";
ziv@2254 293 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
ziv@2254 294 (dummyExp, fm))
ziv@2254 295 in
ziv@2254 296 fooify
ziv@2254 297 end
ziv@2254 298
ziv@2254 299 fun urlify env expTyp =
ziv@2254 300 let
ziv@2254 301 val (exp, fm) =
ziv@2254 302 fooifyExp
ziv@2254 303 Url
ziv@2254 304 (fn n =>
ziv@2254 305 let
ziv@2254 306 val (_, t, _, s) = MonoEnv.lookupENamed env n
ziv@2254 307 in
ziv@2254 308 (t, s)
ziv@2254 309 end)
ziv@2254 310 (fn n => MonoEnv.lookupDatatype env n)
ziv@2254 311 (!Fm.canonical)
ziv@2254 312 expTyp
ziv@2254 313 in
ziv@2254 314 Fm.canonical := fm;
ziv@2254 315 exp
ziv@2254 316 end
ziv@2254 317 end