Mercurial > urweb

annotate src/mono_fooify.sml @ 2307:6ae9a2784a45

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Return to working version mode
author Adam Chlipala <adam@chlipala.net>
date Sun, 20 Dec 2015 14:39:50 -0500
parents a647a1560628
children
rev   line source
ziv@2260 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 end
ziv@2254 116
ziv@2254 117 fun fk2s fk =
ziv@2254 118 case fk of
ziv@2254 119 Attr => "attr"
ziv@2254 120 | Url => "url"
ziv@2254 121
ziv@2254 122 fun capitalize s =
ziv@2254 123 if s = "" then
ziv@2254 124 s
ziv@2254 125 else
ziv@2254 126 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
ziv@2254 127
ziv@2254 128 structure E = ErrorMsg
ziv@2254 129
ziv@2262 130 exception TypeMismatch of Fm.t * E.span
ziv@2262 131 exception CantPass of Fm.t * typ
ziv@2262 132 exception DontKnow of Fm.t * typ
ziv@2262 133
ziv@2254 134 val dummyExp = (EPrim (Prim.Int 0), E.dummySpan)
ziv@2254 135
ziv@2262 136 fun fooifyExpWithExceptions fk lookupENamed lookupDatatype =
ziv@2254 137 let
ziv@2254 138 fun fooify fm (e, tAll as (t, loc)) =
ziv@2254 139 case #1 e of
ziv@2254 140 EClosure (fnam, [(ERecord [], _)]) =>
ziv@2254 141 let
ziv@2254 142 val (_, s) = lookupENamed fnam
ziv@2254 143 in
ziv@2254 144 ((EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm)
ziv@2254 145 end
ziv@2254 146 | EClosure (fnam, args) =>
ziv@2254 147 let
ziv@2254 148 val (ft, s) = lookupENamed fnam
ziv@2254 149 fun attrify (args, ft, e, fm) =
ziv@2254 150 case (args, ft) of
ziv@2254 151 ([], _) => (e, fm)
ziv@2254 152 | (arg :: args, (TFun (t, ft), _)) =>
ziv@2254 153 let
ziv@2254 154 val (arg', fm) = fooify fm (arg, t)
ziv@2254 155 in
ziv@2254 156 attrify (args, ft,
ziv@2254 157 (EStrcat (e,
ziv@2254 158 (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc),
ziv@2254 159 arg'), loc)), loc),
ziv@2254 160 fm)
ziv@2254 161 end
ziv@2262 162 | _ => raise TypeMismatch (fm, loc)
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@2256 169 | TFfi (m, x) => (if Settings.mayClientToServer (m, x)
ziv@2262 170 then ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)
ziv@2262 171 else raise CantPass (fm, tAll))
ziv@2254 172
ziv@2254 173 | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm)
ziv@2254 174 | TRecord ((x, t) :: xts) =>
ziv@2254 175 let
ziv@2254 176 val (se, fm) = fooify fm ((EField (e, x), loc), t)
ziv@2254 177 in
ziv@2254 178 foldl (fn ((x, t), (se, fm)) =>
ziv@2254 179 let
ziv@2254 180 val (se', fm) = fooify fm ((EField (e, x), loc), t)
ziv@2254 181 in
ziv@2254 182 ((EStrcat (se,
ziv@2254 183 (EStrcat ((EPrim (Prim.String (Prim.Normal, "/")), loc),
ziv@2254 184 se'), loc)), loc),
ziv@2254 185 fm)
ziv@2254 186 end) (se, fm) xts
ziv@2254 187 end
ziv@2254 188
ziv@2254 189 | TDatatype (i, ref (dk, _)) =>
ziv@2254 190 let
ziv@2254 191 fun makeDecl n fm =
ziv@2254 192 let
ziv@2254 193 val (x, xncs) =
ziv@2254 194 case ListUtil.search (fn (x, i', xncs) =>
ziv@2254 195 if i' = i then
ziv@2254 196 SOME (x, xncs)
ziv@2254 197 else
ziv@2254 198 NONE) (!pvarDefs) of
ziv@2254 199 NONE => lookupDatatype i
ziv@2254 200 | SOME v => v
ziv@2254 201
ziv@2254 202 val (branches, fm) =
ziv@2254 203 ListUtil.foldlMap
ziv@2254 204 (fn ((x, n, to), fm) =>
ziv@2254 205 case to of
ziv@2254 206 NONE =>
ziv@2254 207 (((PCon (dk, PConVar n, NONE), loc),
ziv@2254 208 (EPrim (Prim.String (Prim.Normal, x)), loc)),
ziv@2254 209 fm)
ziv@2254 210 | SOME t =>
ziv@2254 211 let
ziv@2254 212 val (arg, fm) = fooify fm ((ERel 0, loc), t)
ziv@2254 213 in
ziv@2254 214 (((PCon (dk, PConVar n, SOME (PVar ("a", t), loc)), loc),
ziv@2254 215 (EStrcat ((EPrim (Prim.String (Prim.Normal, x ^ "/")), loc),
ziv@2254 216 arg), loc)),
ziv@2254 217 fm)
ziv@2254 218 end)
ziv@2254 219 fm xncs
ziv@2254 220
ziv@2254 221 val dom = tAll
ziv@2254 222 val ran = (TFfi ("Basis", "string"), loc)
ziv@2254 223 in
ziv@2254 224 ((fk2s fk ^ "ify_" ^ x,
ziv@2254 225 n,
ziv@2254 226 (TFun (dom, ran), loc),
ziv@2254 227 (EAbs ("x",
ziv@2254 228 dom,
ziv@2254 229 ran,
ziv@2254 230 (ECase ((ERel 0, loc),
ziv@2254 231 branches,
ziv@2254 232 {disc = dom,
ziv@2254 233 result = ran}), loc)), loc),
ziv@2254 234 ""),
ziv@2254 235 fm)
ziv@2254 236 end
ziv@2254 237
ziv@2254 238 val (fm, n) = Fm.lookup fm fk i makeDecl
ziv@2254 239 in
ziv@2254 240 ((EApp ((ENamed n, loc), e), loc), fm)
ziv@2254 241 end
ziv@2254 242
ziv@2254 243 | TOption t =>
ziv@2254 244 let
ziv@2254 245 val (body, fm) = fooify fm ((ERel 0, loc), t)
ziv@2254 246 in
ziv@2254 247 ((ECase (e,
ziv@2254 248 [((PNone t, loc),
ziv@2254 249 (EPrim (Prim.String (Prim.Normal, "None")), loc)),
ziv@2254 250
ziv@2254 251 ((PSome (t, (PVar ("x", t), loc)), loc),
ziv@2254 252 (EStrcat ((EPrim (Prim.String (Prim.Normal, "Some/")), loc),
ziv@2254 253 body), loc))],
ziv@2254 254 {disc = tAll,
ziv@2254 255 result = (TFfi ("Basis", "string"), loc)}), loc),
ziv@2254 256 fm)
ziv@2254 257 end
ziv@2254 258
ziv@2254 259 | TList t =>
ziv@2254 260 let
ziv@2254 261 fun makeDecl n fm =
ziv@2254 262 let
ziv@2254 263 val rt = (TRecord [("1", t), ("2", (TList t, loc))], loc)
ziv@2254 264 val (arg, fm) = fooify fm ((ERel 0, loc), rt)
ziv@2254 265
ziv@2254 266 val branches = [((PNone rt, loc),
ziv@2254 267 (EPrim (Prim.String (Prim.Normal, "Nil")), loc)),
ziv@2254 268 ((PSome (rt, (PVar ("a", rt), loc)), loc),
ziv@2254 269 (EStrcat ((EPrim (Prim.String (Prim.Normal, "Cons/")), loc),
ziv@2254 270 arg), loc))]
ziv@2254 271
ziv@2254 272 val dom = tAll
ziv@2254 273 val ran = (TFfi ("Basis", "string"), loc)
ziv@2254 274 in
ziv@2254 275 ((fk2s fk ^ "ify_list",
ziv@2254 276 n,
ziv@2254 277 (TFun (dom, ran), loc),
ziv@2254 278 (EAbs ("x",
ziv@2254 279 dom,
ziv@2254 280 ran,
ziv@2254 281 (ECase ((ERel 0, loc),
ziv@2254 282 branches,
ziv@2254 283 {disc = dom,
ziv@2254 284 result = ran}), loc)), loc),
ziv@2254 285 ""),
ziv@2254 286 fm)
ziv@2254 287 end
ziv@2254 288
ziv@2254 289 val (fm, n) = Fm.lookupList fm fk t makeDecl
ziv@2254 290 in
ziv@2254 291 ((EApp ((ENamed n, loc), e), loc), fm)
ziv@2254 292 end
ziv@2254 293
ziv@2262 294 | _ => raise DontKnow (fm, tAll)
ziv@2254 295 in
ziv@2254 296 fooify
ziv@2254 297 end
ziv@2254 298
ziv@2262 299 fun fooifyExp fk lookupENamed lookupDatatype fm exp =
ziv@2262 300 fooifyExpWithExceptions fk lookupENamed lookupDatatype fm exp
ziv@2262 301 handle TypeMismatch (fm, loc) =>
ziv@2262 302 (E.errorAt loc "Type mismatch encoding attribute";
ziv@2262 303 (dummyExp, fm))
ziv@2262 304 | CantPass (fm, typ as (_, loc)) =>
ziv@2262 305 (E.errorAt loc "MonoFooify: can't pass type from client to server";
ziv@2262 306 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)];
ziv@2262 307 (dummyExp, fm))
ziv@2262 308 | DontKnow (fm, typ as (_, loc)) =>
ziv@2262 309 (E.errorAt loc "Don't know how to encode attribute/URL type";
ziv@2262 310 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty typ)];
ziv@2262 311 (dummyExp, fm))
ziv@2262 312
ziv@2256 313 (* Has to be set at the end of [Monoize]. *)
ziv@2256 314 val canonicalFm = ref (Fm.empty 0 : Fm.t)
ziv@2256 315
ziv@2254 316 fun urlify env expTyp =
ziv@2262 317 let
ziv@2262 318 val (exp, fm) =
ziv@2262 319 fooifyExpWithExceptions
ziv@2262 320 Url
ziv@2262 321 (fn n =>
ziv@2262 322 let
ziv@2262 323 val (_, t, _, s) = MonoEnv.lookupENamed env n
ziv@2262 324 in
ziv@2262 325 (t, s)
ziv@2262 326 end)
ziv@2262 327 (fn n => MonoEnv.lookupDatatype env n)
ziv@2262 328 (!canonicalFm)
ziv@2262 329 expTyp
ziv@2262 330 in
ziv@2262 331 canonicalFm := fm;
ziv@2262 332 SOME exp
ziv@2262 333 end
ziv@2262 334 handle TypeMismatch _ => NONE
ziv@2262 335 | CantPass _ => NONE
ziv@2262 336 | DontKnow _ => NONE
ziv@2256 337
ziv@2256 338 fun getNewFmDecls () =
ziv@2254 339 let
ziv@2256 340 val fm = !canonicalFm
ziv@2254 341 in
ziv@2261 342 canonicalFm := Fm.enter fm;
ziv@2256 343 Fm.decls fm
ziv@2254 344 end
ziv@2256 345
ziv@2254 346 end