Mercurial > urweb

annotate src/monoize.sml @ 251:326fb4686f60

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Monoize transaction identifiers; improve disjointness prover on irreducible folds; change 'query' type
author Adam Chlipala <adamc@hcoop.net>
date Sun, 31 Aug 2008 10:36:54 -0400
parents 5c50b17f5e4a
children 7e9bd70ad3ce
rev   line source
adamc@25 1 (* Copyright (c) 2008, Adam Chlipala
adamc@25 2 * All rights reserved.
adamc@25 3 *
adamc@25 4 * Redistribution and use in source and binary forms, with or without
adamc@25 5 * modification, are permitted provided that the following conditions are met:
adamc@25 6 *
adamc@25 7 * - Redistributions of source code must retain the above copyright notice,
adamc@25 8 * this list of conditions and the following disclaimer.
adamc@25 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@25 10 * this list of conditions and the following disclaimer in the documentation
adamc@25 11 * and/or other materials provided with the distribution.
adamc@25 12 * - The names of contributors may not be used to endorse or promote products
adamc@25 13 * derived from this software without specific prior written permission.
adamc@25 14 *
adamc@25 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@25 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@25 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@25 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@25 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@25 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@25 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@25 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@25 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@25 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@25 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@25 26 *)
adamc@25 27
adamc@25 28 structure Monoize :> MONOIZE = struct
adamc@25 29
adamc@25 30 structure E = ErrorMsg
adamc@25 31 structure Env = CoreEnv
adamc@25 32
adamc@25 33 structure L = Core
adamc@25 34 structure L' = Mono
adamc@25 35
adamc@196 36 structure IM = IntBinaryMap
adamc@196 37
adamc@196 38 val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan)
adamc@25 39
adamc@25 40 fun monoName env (all as (c, loc)) =
adamc@25 41 let
adamc@25 42 fun poly () =
adamc@25 43 (E.errorAt loc "Unsupported name constructor";
adamc@25 44 Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
adamc@25 45 "")
adamc@25 46 in
adamc@25 47 case c of
adamc@25 48 L.CName s => s
adamc@25 49 | _ => poly ()
adamc@25 50 end
adamc@25 51
adamc@196 52 fun monoType env =
adamc@25 53 let
adamc@196 54 fun mt env dtmap (all as (c, loc)) =
adamc@196 55 let
adamc@196 56 fun poly () =
adamc@196 57 (E.errorAt loc "Unsupported type constructor";
adamc@196 58 Print.eprefaces' [("Constructor", CorePrint.p_con env all)];
adamc@196 59 dummyTyp)
adamc@196 60 in
adamc@196 61 case c of
adamc@196 62 L.TFun (c1, c2) => (L'.TFun (mt env dtmap c1, mt env dtmap c2), loc)
adamc@196 63 | L.TCFun _ => poly ()
adamc@196 64 | L.TRecord (L.CRecord ((L.KType, _), xcs), _) =>
adamc@196 65 (L'.TRecord (map (fn (x, t) => (monoName env x, mt env dtmap t)) xcs), loc)
adamc@196 66 | L.TRecord _ => poly ()
adamc@196 67
adamc@196 68 | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) =>
adamc@196 69 (L'.TFfi ("Basis", "string"), loc)
adamc@196 70 | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
adamc@196 71 (L'.TFfi ("Basis", "string"), loc)
adamc@196 72
adamc@251 73 | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
adamc@251 74 (L'.TFun (mt env dtmap t, (L'.TRecord [], loc)), loc)
adamc@251 75
adamc@196 76 | L.CRel _ => poly ()
adamc@196 77 | L.CNamed n =>
adamc@196 78 (case IM.find (dtmap, n) of
adamc@196 79 SOME r => (L'.TDatatype (n, r), loc)
adamc@196 80 | NONE =>
adamc@196 81 let
adamc@196 82 val r = ref (L'.Default, [])
adamc@196 83 val (_, xs, xncs) = Env.lookupDatatype env n
adamc@196 84
adamc@196 85 val dtmap' = IM.insert (dtmap, n, r)
adamc@196 86
adamc@196 87 val xncs = map (fn (x, n, to) => (x, n, Option.map (mt env dtmap') to)) xncs
adamc@196 88 in
adamc@196 89 case xs of
adamc@198 90 [] =>(r := (ElabUtil.classifyDatatype xncs, xncs);
adamc@196 91 (L'.TDatatype (n, r), loc))
adamc@196 92 | _ => poly ()
adamc@196 93 end)
adamc@196 94 | L.CFfi mx => (L'.TFfi mx, loc)
adamc@196 95 | L.CApp _ => poly ()
adamc@196 96 | L.CAbs _ => poly ()
adamc@196 97
adamc@196 98 | L.CName _ => poly ()
adamc@196 99
adamc@196 100 | L.CRecord _ => poly ()
adamc@196 101 | L.CConcat _ => poly ()
adamc@196 102 | L.CFold _ => poly ()
adamc@196 103 | L.CUnit => poly ()
adamc@214 104
adamc@214 105 | L.CTuple _ => poly ()
adamc@214 106 | L.CProj _ => poly ()
adamc@196 107 end
adamc@25 108 in
adamc@196 109 mt env IM.empty
adamc@25 110 end
adamc@25 111
adamc@25 112 val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
adamc@25 113
adamc@179 114 structure IM = IntBinaryMap
adamc@179 115
adamc@179 116 datatype foo_kind =
adamc@179 117 Attr
adamc@179 118 | Url
adamc@179 119
adamc@179 120 fun fk2s fk =
adamc@179 121 case fk of
adamc@179 122 Attr => "attr"
adamc@179 123 | Url => "url"
adamc@179 124
adamc@179 125 structure Fm :> sig
adamc@179 126 type t
adamc@179 127
adamc@179 128 val empty : int -> t
adamc@179 129
adamc@179 130 val lookup : t -> foo_kind -> int -> (int -> t -> L'.decl * t) -> t * int
adamc@179 131 val enter : t -> t
adamc@179 132 val decls : t -> L'.decl list
adamc@179 133 end = struct
adamc@179 134
adamc@179 135 structure M = BinaryMapFn(struct
adamc@179 136 type ord_key = foo_kind
adamc@179 137 fun compare x =
adamc@179 138 case x of
adamc@179 139 (Attr, Attr) => EQUAL
adamc@179 140 | (Attr, _) => LESS
adamc@179 141 | (_, Attr) => GREATER
adamc@179 142
adamc@179 143 | (Url, Url) => EQUAL
adamc@179 144 end)
adamc@179 145
adamc@179 146 type t = {
adamc@179 147 count : int,
adamc@179 148 map : int IM.map M.map,
adamc@179 149 decls : L'.decl list
adamc@179 150 }
adamc@179 151
adamc@179 152 fun empty count = {
adamc@179 153 count = count,
adamc@179 154 map = M.empty,
adamc@179 155 decls = []
adamc@179 156 }
adamc@179 157
adamc@179 158 fun enter ({count, map, ...} : t) = {count = count, map = map, decls = []}
adamc@179 159 fun decls ({decls, ...} : t) = decls
adamc@179 160
adamc@179 161 fun lookup (t as {count, map, decls}) k n thunk =
adamc@120 162 let
adamc@179 163 val im = Option.getOpt (M.find (map, k), IM.empty)
adamc@179 164 in
adamc@179 165 case IM.find (im, n) of
adamc@179 166 NONE =>
adamc@179 167 let
adamc@179 168 val n' = count
adamc@179 169 val (d, {count, map, decls}) = thunk count {count = count + 1,
adamc@179 170 map = M.insert (map, k, IM.insert (im, n, n')),
adamc@179 171 decls = decls}
adamc@179 172 in
adamc@179 173 ({count = count,
adamc@179 174 map = map,
adamc@179 175 decls = d :: decls}, n')
adamc@179 176 end
adamc@179 177 | SOME n' => (t, n')
adamc@179 178 end
adamc@179 179
adamc@179 180 end
adamc@185 181
adamc@185 182
adamc@185 183 fun capitalize s =
adamc@185 184 if s = "" then
adamc@185 185 s
adamc@185 186 else
adamc@185 187 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
adamc@179 188
adamc@179 189 fun fooifyExp fk env =
adamc@179 190 let
adamc@179 191 fun fooify fm (e, tAll as (t, loc)) =
adamc@120 192 case #1 e of
adamc@120 193 L'.EClosure (fnam, [(L'.ERecord [], _)]) =>
adamc@120 194 let
adamc@120 195 val (_, _, _, s) = Env.lookupENamed env fnam
adamc@120 196 in
adamc@183 197 ((L'.EPrim (Prim.String ("/" ^ s)), loc), fm)
adamc@120 198 end
adamc@120 199 | L'.EClosure (fnam, args) =>
adamc@120 200 let
adamc@120 201 val (_, ft, _, s) = Env.lookupENamed env fnam
adamc@120 202 val ft = monoType env ft
adamc@111 203
adamc@179 204 fun attrify (args, ft, e, fm) =
adamc@120 205 case (args, ft) of
adamc@179 206 ([], _) => (e, fm)
adamc@120 207 | (arg :: args, (L'.TFun (t, ft), _)) =>
adamc@179 208 let
adamc@179 209 val (arg', fm) = fooify fm (arg, t)
adamc@179 210 in
adamc@179 211 attrify (args, ft,
adamc@179 212 (L'.EStrcat (e,
adamc@179 213 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
adamc@179 214 arg'), loc)), loc),
adamc@179 215 fm)
adamc@179 216 end
adamc@120 217 | _ => (E.errorAt loc "Type mismatch encoding attribute";
adamc@179 218 (e, fm))
adamc@120 219 in
adamc@183 220 attrify (args, ft, (L'.EPrim (Prim.String ("/" ^ s)), loc), fm)
adamc@120 221 end
adamc@120 222 | _ =>
adamc@120 223 case t of
adamc@185 224 L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm)
adamc@200 225
adamc@179 226 | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm)
adamc@200 227 | L'.TRecord ((x, t) :: xts) =>
adamc@200 228 let
adamc@200 229 val (se, fm) = fooify fm ((L'.EField (e, x), loc), t)
adamc@200 230 in
adamc@200 231 foldl (fn ((x, t), (se, fm)) =>
adamc@200 232 let
adamc@200 233 val (se', fm) = fooify fm ((L'.EField (e, x), loc), t)
adamc@200 234 in
adamc@200 235 ((L'.EStrcat (se,
adamc@200 236 (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
adamc@200 237 se'), loc)), loc),
adamc@200 238 fm)
adamc@200 239 end) (se, fm) xts
adamc@200 240 end
adamc@111 241
adamc@196 242 | L'.TDatatype (i, ref (dk, _)) =>
adamc@179 243 let
adamc@179 244 fun makeDecl n fm =
adamc@179 245 let
adamc@193 246 val (x, _, xncs) = Env.lookupDatatype env i
adamc@179 247
adamc@179 248 val (branches, fm) =
adamc@179 249 ListUtil.foldlMap
adamc@179 250 (fn ((x, n, to), fm) =>
adamc@179 251 case to of
adamc@179 252 NONE =>
adamc@188 253 (((L'.PCon (dk, L'.PConVar n, NONE), loc),
adamc@179 254 (L'.EPrim (Prim.String x), loc)),
adamc@179 255 fm)
adamc@179 256 | SOME t =>
adamc@179 257 let
adamc@182 258 val t = monoType env t
adamc@182 259 val (arg, fm) = fooify fm ((L'.ERel 0, loc), t)
adamc@179 260 in
adamc@188 261 (((L'.PCon (dk, L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc),
adamc@179 262 (L'.EStrcat ((L'.EPrim (Prim.String (x ^ "/")), loc),
adamc@179 263 arg), loc)),
adamc@179 264 fm)
adamc@179 265 end)
adamc@179 266 fm xncs
adamc@179 267
adamc@179 268 val dom = tAll
adamc@179 269 val ran = (L'.TFfi ("Basis", "string"), loc)
adamc@179 270 in
adamc@179 271 ((L'.DValRec [(fk2s fk ^ "ify_" ^ x,
adamc@179 272 n,
adamc@179 273 (L'.TFun (dom, ran), loc),
adamc@179 274 (L'.EAbs ("x",
adamc@179 275 dom,
adamc@179 276 ran,
adamc@179 277 (L'.ECase ((L'.ERel 0, loc),
adamc@179 278 branches,
adamc@182 279 {disc = dom,
adamc@182 280 result = ran}), loc)), loc),
adamc@179 281 "")], loc),
adamc@179 282 fm)
adamc@179 283 end
adamc@179 284
adamc@179 285 val (fm, n) = Fm.lookup fm fk i makeDecl
adamc@179 286 in
adamc@179 287 ((L'.EApp ((L'.ENamed n, loc), e), loc), fm)
adamc@179 288 end
adamc@164 289
adamc@120 290 | _ => (E.errorAt loc "Don't know how to encode attribute type";
adamc@120 291 Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
adamc@179 292 (dummyExp, fm))
adamc@120 293 in
adamc@120 294 fooify
adamc@120 295 end
adamc@120 296
adamc@179 297 val attrifyExp = fooifyExp Attr
adamc@179 298 val urlifyExp = fooifyExp Url
adamc@105 299
adamc@143 300 datatype 'a failable_search =
adamc@143 301 Found of 'a
adamc@143 302 | NotFound
adamc@143 303 | Error
adamc@143 304
adamc@153 305 structure St :> sig
adamc@153 306 type t
adamc@153 307
adamc@153 308 val empty : t
adamc@153 309
adamc@153 310 val radioGroup : t -> string option
adamc@153 311 val setRadioGroup : t * string -> t
adamc@153 312 end = struct
adamc@153 313
adamc@153 314 type t = {
adamc@153 315 radioGroup : string option
adamc@153 316 }
adamc@153 317
adamc@153 318 val empty = {radioGroup = NONE}
adamc@153 319
adamc@153 320 fun radioGroup (t : t) = #radioGroup t
adamc@153 321
adamc@153 322 fun setRadioGroup (t : t, x) = {radioGroup = SOME x}
adamc@153 323
adamc@153 324 end
adamc@153 325
adamc@186 326 fun monoPatCon env pc =
adamc@178 327 case pc of
adamc@178 328 L.PConVar n => L'.PConVar n
adamc@188 329 | L.PConFfi {mod = m, datatyp, con, arg, ...} => L'.PConFfi {mod = m, datatyp = datatyp, con = con,
adamc@188 330 arg = Option.map (monoType env) arg}
adamc@178 331
adamc@193 332 val dummyPat = (L'.PPrim (Prim.Int 0), ErrorMsg.dummySpan)
adamc@193 333
adamc@193 334 fun monoPat env (all as (p, loc)) =
adamc@193 335 let
adamc@193 336 fun poly () =
adamc@193 337 (E.errorAt loc "Unsupported pattern";
adamc@193 338 Print.eprefaces' [("Pattern", CorePrint.p_pat env all)];
adamc@193 339 dummyPat)
adamc@193 340 in
adamc@193 341 case p of
adamc@193 342 L.PWild => (L'.PWild, loc)
adamc@193 343 | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc)
adamc@193 344 | L.PPrim p => (L'.PPrim p, loc)
adamc@193 345 | L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc)
adamc@193 346 | L.PCon _ => poly ()
adamc@193 347 | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
adamc@193 348 end
adamc@178 349
adamc@179 350 fun monoExp (env, st, fm) (all as (e, loc)) =
adamc@25 351 let
adamc@25 352 fun poly () =
adamc@25 353 (E.errorAt loc "Unsupported expression";
adamc@25 354 Print.eprefaces' [("Expression", CorePrint.p_exp env all)];
adamc@179 355 (dummyExp, fm))
adamc@25 356 in
adamc@25 357 case e of
adamc@179 358 L.EPrim p => ((L'.EPrim p, loc), fm)
adamc@179 359 | L.ERel n => ((L'.ERel n, loc), fm)
adamc@179 360 | L.ENamed n => ((L'.ENamed n, loc), fm)
adamc@193 361 | L.ECon (dk, pc, [], eo) =>
adamc@193 362 let
adamc@179 363 val (eo, fm) =
adamc@179 364 case eo of
adamc@179 365 NONE => (NONE, fm)
adamc@179 366 | SOME e =>
adamc@179 367 let
adamc@179 368 val (e, fm) = monoExp (env, st, fm) e
adamc@179 369 in
adamc@179 370 (SOME e, fm)
adamc@179 371 end
adamc@179 372 in
adamc@188 373 ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm)
adamc@193 374 end
adamc@193 375 | L.ECon _ => poly ()
adamc@179 376 | L.EFfi mx => ((L'.EFfi mx, loc), fm)
adamc@179 377 | L.EFfiApp (m, x, es) =>
adamc@179 378 let
adamc@179 379 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
adamc@179 380 in
adamc@179 381 ((L'.EFfiApp (m, x, es), loc), fm)
adamc@179 382 end
adamc@94 383
adamc@251 384 | L.ECApp ((L.EFfi ("Basis", "return"), _), t) =>
adamc@251 385 ((L'.EAbs ("x", monoType env t, (L'.TRecord [], loc), (L'.ERel 0, loc)), loc), fm)
adamc@251 386 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), t1), _), t2) =>
adamc@251 387 let
adamc@251 388 val t1 = monoType env t1
adamc@251 389 val t2 = monoType env t2
adamc@251 390 val un = (L'.TRecord [], loc)
adamc@251 391 val mt1 = (L'.TFun (t1, un), loc)
adamc@251 392 val mt2 = (L'.TFun (t2, un), loc)
adamc@251 393 in
adamc@251 394 ((L'.EAbs ("m1", mt1, (L'.TFun (mt1, (L'.TFun (mt2, un), loc)), loc),
adamc@251 395 (L'.EAbs ("m2", mt2, un,
adamc@251 396 (L'.ELet ("r", t1, (L'.ERel 1, loc),
adamc@251 397 (L'.EApp ((L'.ERel 1, loc), (L'.ERel 0, loc)),
adamc@251 398 loc)), loc)), loc)), loc),
adamc@251 399 fm)
adamc@251 400 end
adamc@251 401
adamc@139 402 | L.EApp (
adamc@139 403 (L.ECApp (
adamc@141 404 (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
adamc@139 405 _), _),
adamc@179 406 se) =>
adamc@179 407 let
adamc@179 408 val (se, fm) = monoExp (env, st, fm) se
adamc@179 409 in
adamc@179 410 ((L'.EFfiApp ("Basis", "htmlifyString", [se]), loc), fm)
adamc@179 411 end
adamc@179 412
adamc@95 413 | L.EApp (
adamc@95 414 (L.EApp (
adamc@95 415 (L.ECApp (
adamc@95 416 (L.ECApp (
adamc@95 417 (L.ECApp (
adamc@139 418 (L.ECApp (
adamc@140 419 (L.EFfi ("Basis", "join"),
adamc@139 420 _), _), _),
adamc@139 421 _), _),
adamc@95 422 _), _),
adamc@95 423 _), _),
adamc@95 424 xml1), _),
adamc@179 425 xml2) =>
adamc@179 426 let
adamc@179 427 val (xml1, fm) = monoExp (env, st, fm) xml1
adamc@179 428 val (xml2, fm) = monoExp (env, st, fm) xml2
adamc@179 429 in
adamc@179 430 ((L'.EStrcat (xml1, xml2), loc), fm)
adamc@179 431 end
adamc@95 432
adamc@95 433 | L.EApp (
adamc@95 434 (L.EApp (
adamc@104 435 (L.EApp (
adamc@95 436 (L.ECApp (
adamc@104 437 (L.ECApp (
adamc@104 438 (L.ECApp (
adamc@104 439 (L.ECApp (
adamc@139 440 (L.ECApp (
adamc@139 441 (L.ECApp (
adamc@139 442 (L.ECApp (
adamc@139 443 (L.ECApp (
adamc@139 444 (L.EFfi ("Basis", "tag"),
adamc@139 445 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
adamc@104 446 attrs), _),
adamc@95 447 tag), _),
adamc@95 448 xml) =>
adamc@95 449 let
adamc@140 450 fun getTag' (e, _) =
adamc@140 451 case e of
adamc@143 452 L.EFfi ("Basis", tag) => (tag, [])
adamc@143 453 | L.ECApp (e, t) => let
adamc@143 454 val (tag, ts) = getTag' e
adamc@143 455 in
adamc@143 456 (tag, ts @ [t])
adamc@143 457 end
adamc@140 458 | _ => (E.errorAt loc "Non-constant XML tag";
adamc@140 459 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
adamc@143 460 ("", []))
adamc@140 461
adamc@95 462 fun getTag (e, _) =
adamc@95 463 case e of
adamc@143 464 L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => (tag, [])
adamc@140 465 | L.EApp (e, (L.ERecord [], _)) => getTag' e
adamc@95 466 | _ => (E.errorAt loc "Non-constant XML tag";
adamc@95 467 Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
adamc@143 468 ("", []))
adamc@95 469
adamc@143 470 val (tag, targs) = getTag tag
adamc@95 471
adamc@179 472 val (attrs, fm) = monoExp (env, st, fm) attrs
adamc@104 473
adamc@143 474 fun tagStart tag =
adamc@104 475 case #1 attrs of
adamc@104 476 L'.ERecord xes =>
adamc@104 477 let
adamc@104 478 fun lowercaseFirst "" = ""
adamc@143 479 | lowercaseFirst s = str (Char.toLower (String.sub (s, 0)))
adamc@143 480 ^ String.extract (s, 1, NONE)
adamc@104 481
adamc@104 482 val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc)
adamc@104 483 in
adamc@179 484 foldl (fn ((x, e, t), (s, fm)) =>
adamc@104 485 let
adamc@104 486 val xp = " " ^ lowercaseFirst x ^ "=\""
adamc@120 487
adamc@120 488 val fooify =
adamc@120 489 case x of
adamc@185 490 "Href" => urlifyExp
adamc@185 491 | "Link" => urlifyExp
adamc@143 492 | "Action" => urlifyExp
adamc@120 493 | _ => attrifyExp
adamc@179 494
adamc@179 495 val (e, fm) = fooify env fm (e, t)
adamc@104 496 in
adamc@179 497 ((L'.EStrcat (s,
adamc@179 498 (L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
adamc@179 499 (L'.EStrcat (e,
adamc@179 500 (L'.EPrim (Prim.String "\""),
adamc@179 501 loc)),
adamc@179 502 loc)),
adamc@179 503 loc)), loc),
adamc@179 504 fm)
adamc@104 505 end)
adamc@179 506 (s, fm) xes
adamc@104 507 end
adamc@143 508 | _ => raise Fail "Non-record attributes!"
adamc@104 509
adamc@143 510 fun input typ =
adamc@143 511 case targs of
adamc@155 512 [_, (L.CName name, _)] =>
adamc@179 513 let
adamc@179 514 val (ts, fm) = tagStart "input"
adamc@179 515 in
adamc@179 516 ((L'.EStrcat (ts,
adamc@179 517 (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\"/>")),
adamc@179 518 loc)), loc), fm)
adamc@179 519 end
adamc@143 520 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@153 521 raise Fail "No name passed to input tag")
adamc@104 522
adamc@152 523 fun normal (tag, extra) =
adamc@143 524 let
adamc@179 525 val (tagStart, fm) = tagStart tag
adamc@152 526 val tagStart = case extra of
adamc@152 527 NONE => tagStart
adamc@152 528 | SOME extra => (L'.EStrcat (tagStart, extra), loc)
adamc@152 529
adamc@143 530 fun normal () =
adamc@179 531 let
adamc@179 532 val (xml, fm) = monoExp (env, st, fm) xml
adamc@179 533 in
adamc@179 534 ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
adamc@179 535 (L'.EStrcat (xml,
adamc@179 536 (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])),
adamc@179 537 loc)), loc)),
adamc@179 538 loc),
adamc@179 539 fm)
adamc@179 540 end
adamc@143 541 in
adamc@143 542 case xml of
adamc@143 543 (L.EApp ((L.ECApp (
adamc@143 544 (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
adamc@143 545 _), _),
adamc@143 546 _), _),
adamc@143 547 (L.EPrim (Prim.String s), _)), _) =>
adamc@143 548 if CharVector.all Char.isSpace s then
adamc@179 549 ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc), fm)
adamc@143 550 else
adamc@143 551 normal ()
adamc@143 552 | _ => normal ()
adamc@143 553 end
adamc@152 554 in
adamc@152 555 case tag of
adamc@179 556 "submit" => ((L'.EPrim (Prim.String "<input type=\"submit\"/>"), loc), fm)
adamc@152 557
adamc@152 558 | "textbox" =>
adamc@152 559 (case targs of
adamc@152 560 [_, (L.CName name, _)] =>
adamc@179 561 let
adamc@179 562 val (ts, fm) = tagStart "input"
adamc@179 563 in
adamc@179 564 ((L'.EStrcat (ts,
adamc@179 565 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")),
adamc@179 566 loc)), loc), fm)
adamc@179 567 end
adamc@152 568 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@153 569 raise Fail "No name passed to textarea tag"))
adamc@155 570 | "password" => input "password"
adamc@152 571 | "ltextarea" =>
adamc@152 572 (case targs of
adamc@152 573 [_, (L.CName name, _)] =>
adamc@179 574 let
adamc@179 575 val (ts, fm) = tagStart "textarea"
adamc@179 576 val (xml, fm) = monoExp (env, st, fm) xml
adamc@179 577 in
adamc@179 578 ((L'.EStrcat ((L'.EStrcat (ts,
adamc@179 579 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
adamc@179 580 (L'.EStrcat (xml,
adamc@179 581 (L'.EPrim (Prim.String "</textarea>"),
adamc@179 582 loc)), loc)),
adamc@179 583 loc), fm)
adamc@179 584 end
adamc@152 585 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@153 586 raise Fail "No name passed to ltextarea tag"))
adamc@153 587
adamc@190 588 | "checkbox" => input "checkbox"
adamc@190 589
adamc@153 590 | "radio" =>
adamc@153 591 (case targs of
adamc@153 592 [_, (L.CName name, _)] =>
adamc@179 593 monoExp (env, St.setRadioGroup (st, name), fm) xml
adamc@153 594 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@153 595 raise Fail "No name passed to radio tag"))
adamc@153 596 | "radioOption" =>
adamc@153 597 (case St.radioGroup st of
adamc@153 598 NONE => raise Fail "No name for radioGroup"
adamc@153 599 | SOME name =>
adamc@153 600 normal ("input",
adamc@153 601 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc)))
adamc@152 602
adamc@154 603 | "lselect" =>
adamc@154 604 (case targs of
adamc@154 605 [_, (L.CName name, _)] =>
adamc@179 606 let
adamc@179 607 val (ts, fm) = tagStart "select"
adamc@179 608 val (xml, fm) = monoExp (env, st, fm) xml
adamc@179 609 in
adamc@179 610 ((L'.EStrcat ((L'.EStrcat (ts,
adamc@179 611 (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
adamc@179 612 (L'.EStrcat (xml,
adamc@179 613 (L'.EPrim (Prim.String "</select>"),
adamc@179 614 loc)), loc)),
adamc@179 615 loc),
adamc@179 616 fm)
adamc@179 617 end
adamc@154 618 | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
adamc@154 619 raise Fail "No name passed to lselect tag"))
adamc@154 620
adamc@154 621 | "loption" => normal ("option", NONE)
adamc@154 622
adamc@152 623 | _ => normal (tag, NONE)
adamc@95 624 end
adamc@94 625
adamc@141 626 | L.EApp ((L.ECApp (
adamc@141 627 (L.ECApp ((L.EFfi ("Basis", "lform"), _), _), _),
adamc@141 628 _), _),
adamc@141 629 xml) =>
adamc@143 630 let
adamc@143 631 fun findSubmit (e, _) =
adamc@143 632 case e of
adamc@143 633 L.EApp (
adamc@143 634 (L.EApp (
adamc@143 635 (L.ECApp (
adamc@143 636 (L.ECApp (
adamc@143 637 (L.ECApp (
adamc@143 638 (L.ECApp (
adamc@143 639 (L.EFfi ("Basis", "join"),
adamc@143 640 _), _), _),
adamc@143 641 _), _),
adamc@143 642 _), _),
adamc@143 643 _), _),
adamc@143 644 xml1), _),
adamc@143 645 xml2) => (case findSubmit xml1 of
adamc@143 646 Error => Error
adamc@143 647 | NotFound => findSubmit xml2
adamc@143 648 | Found e =>
adamc@143 649 case findSubmit xml2 of
adamc@143 650 NotFound => Found e
adamc@143 651 | _ => Error)
adamc@143 652 | L.EApp (
adamc@143 653 (L.EApp (
adamc@143 654 (L.EApp (
adamc@143 655 (L.ECApp (
adamc@143 656 (L.ECApp (
adamc@143 657 (L.ECApp (
adamc@143 658 (L.ECApp (
adamc@143 659 (L.ECApp (
adamc@143 660 (L.ECApp (
adamc@143 661 (L.ECApp (
adamc@143 662 (L.ECApp (
adamc@143 663 (L.EFfi ("Basis", "tag"),
adamc@143 664 _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
adamc@143 665 attrs), _),
adamc@143 666 _), _),
adamc@143 667 xml) =>
adamc@143 668 (case #1 attrs of
adamc@143 669 L.ERecord xes =>
adamc@143 670 (case ListUtil.search (fn ((L.CName "Action", _), e, t) => SOME (e, t)
adamc@143 671 | _ => NONE) xes of
adamc@143 672 NONE => findSubmit xml
adamc@143 673 | SOME et =>
adamc@143 674 case findSubmit xml of
adamc@143 675 NotFound => Found et
adamc@143 676 | _ => Error)
adamc@143 677 | _ => findSubmit xml)
adamc@143 678 | _ => NotFound
adamc@143 679
adamc@143 680 val (action, actionT) = case findSubmit xml of
adamc@143 681 NotFound => raise Fail "No submit found"
adamc@143 682 | Error => raise Fail "Not ready for multi-submit lforms yet"
adamc@143 683 | Found et => et
adamc@143 684
adamc@143 685 val actionT = monoType env actionT
adamc@179 686 val (action, fm) = monoExp (env, st, fm) action
adamc@179 687 val (action, fm) = urlifyExp env fm (action, actionT)
adamc@179 688 val (xml, fm) = monoExp (env, st, fm) xml
adamc@143 689 in
adamc@179 690 ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form action=\""), loc),
adamc@179 691 (L'.EStrcat (action,
adamc@179 692 (L'.EPrim (Prim.String "\">"), loc)), loc)), loc),
adamc@179 693 (L'.EStrcat (xml,
adamc@179 694 (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc),
adamc@179 695 fm)
adamc@143 696 end
adamc@141 697
adamc@148 698 | L.EApp ((L.ECApp (
adamc@148 699 (L.ECApp (
adamc@148 700 (L.ECApp (
adamc@148 701 (L.ECApp (
adamc@148 702 (L.EFfi ("Basis", "useMore"), _), _), _),
adamc@148 703 _), _),
adamc@148 704 _), _),
adamc@148 705 _), _),
adamc@179 706 xml) => monoExp (env, st, fm) xml
adamc@148 707
adamc@179 708 | L.EApp (e1, e2) =>
adamc@179 709 let
adamc@179 710 val (e1, fm) = monoExp (env, st, fm) e1
adamc@179 711 val (e2, fm) = monoExp (env, st, fm) e2
adamc@179 712 in
adamc@179 713 ((L'.EApp (e1, e2), loc), fm)
adamc@179 714 end
adamc@26 715 | L.EAbs (x, dom, ran, e) =>
adamc@179 716 let
adamc@179 717 val (e, fm) = monoExp (Env.pushERel env x dom, st, fm) e
adamc@179 718 in
adamc@179 719 ((L'.EAbs (x, monoType env dom, monoType env ran, e), loc), fm)
adamc@179 720 end
adamc@25 721 | L.ECApp _ => poly ()
adamc@25 722 | L.ECAbs _ => poly ()
adamc@25 723
adamc@179 724 | L.ERecord xes =>
adamc@179 725 let
adamc@179 726 val (xes, fm) = ListUtil.foldlMap
adamc@179 727 (fn ((x, e, t), fm) =>
adamc@179 728 let
adamc@179 729 val (e, fm) = monoExp (env, st, fm) e
adamc@179 730 in
adamc@179 731 ((monoName env x,
adamc@179 732 e,
adamc@179 733 monoType env t), fm)
adamc@179 734 end) fm xes
adamc@179 735 in
adamc@179 736 ((L'.ERecord xes, loc), fm)
adamc@179 737 end
adamc@179 738 | L.EField (e, x, _) =>
adamc@179 739 let
adamc@179 740 val (e, fm) = monoExp (env, st, fm) e
adamc@179 741 in
adamc@179 742 ((L'.EField (e, monoName env x), loc), fm)
adamc@179 743 end
adamc@149 744 | L.ECut _ => poly ()
adamc@73 745 | L.EFold _ => poly ()
adamc@177 746
adamc@182 747 | L.ECase (e, pes, {disc, result}) =>
adamc@179 748 let
adamc@179 749 val (e, fm) = monoExp (env, st, fm) e
adamc@179 750 val (pes, fm) = ListUtil.foldlMap
adamc@179 751 (fn ((p, e), fm) =>
adamc@179 752 let
adamc@179 753 val (e, fm) = monoExp (env, st, fm) e
adamc@179 754 in
adamc@182 755 ((monoPat env p, e), fm)
adamc@179 756 end) fm pes
adamc@179 757 in
adamc@182 758 ((L'.ECase (e, pes, {disc = monoType env disc, result = monoType env result}), loc), fm)
adamc@179 759 end
adamc@177 760
adamc@179 761 | L.EWrite e =>
adamc@179 762 let
adamc@179 763 val (e, fm) = monoExp (env, st, fm) e
adamc@179 764 in
adamc@179 765 ((L'.EWrite e, loc), fm)
adamc@179 766 end
adamc@110 767
adamc@179 768 | L.EClosure (n, es) =>
adamc@179 769 let
adamc@179 770 val (es, fm) = ListUtil.foldlMap (fn (e, fm) =>
adamc@179 771 monoExp (env, st, fm) e)
adamc@179 772 fm es
adamc@179 773 in
adamc@179 774 ((L'.EClosure (n, es), loc), fm)
adamc@179 775 end
adamc@25 776 end
adamc@25 777
adamc@179 778 fun monoDecl (env, fm) (all as (d, loc)) =
adamc@25 779 let
adamc@25 780 fun poly () =
adamc@25 781 (E.errorAt loc "Unsupported declaration";
adamc@25 782 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
adamc@25 783 NONE)
adamc@25 784 in
adamc@25 785 case d of
adamc@25 786 L.DCon _ => NONE
adamc@193 787 | L.DDatatype (x, n, [], xncs) =>
adamc@193 788 let
adamc@196 789 val env' = Env.declBinds env all
adamc@196 790 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env') to)) xncs), loc)
adamc@164 791 in
adamc@196 792 SOME (env', fm, d)
adamc@193 793 end
adamc@193 794 | L.DDatatype _ => poly ()
adamc@179 795 | L.DVal (x, n, t, e, s) =>
adamc@179 796 let
adamc@179 797 val (e, fm) = monoExp (env, St.empty, fm) e
adamc@179 798 in
adamc@179 799 SOME (Env.pushENamed env x n t NONE s,
adamc@179 800 fm,
adamc@179 801 (L'.DVal (x, n, monoType env t, e, s), loc))
adamc@179 802 end
adamc@128 803 | L.DValRec vis =>
adamc@128 804 let
adamc@128 805 val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis
adamc@179 806
adamc@179 807 val (vis, fm) = ListUtil.foldlMap
adamc@179 808 (fn ((x, n, t, e, s), fm) =>
adamc@179 809 let
adamc@179 810 val (e, fm) = monoExp (env, St.empty, fm) e
adamc@179 811 in
adamc@179 812 ((x, n, monoType env t, e, s), fm)
adamc@179 813 end)
adamc@179 814 fm vis
adamc@128 815 in
adamc@128 816 SOME (env,
adamc@179 817 fm,
adamc@179 818 (L'.DValRec vis, loc))
adamc@128 819 end
adamc@144 820 | L.DExport (ek, n) =>
adamc@115 821 let
adamc@120 822 val (_, t, _, s) = Env.lookupENamed env n
adamc@120 823
adamc@120 824 fun unwind (t, _) =
adamc@120 825 case t of
adamc@120 826 L.TFun (dom, ran) => dom :: unwind ran
adamc@120 827 | _ => []
adamc@120 828
adamc@120 829 val ts = map (monoType env) (unwind t)
adamc@115 830 in
adamc@179 831 SOME (env, fm, (L'.DExport (ek, s, n, ts), loc))
adamc@115 832 end
adamc@251 833 | L.DTable (x, n, _, s) =>
adamc@251 834 let
adamc@251 835 val t = (L.CFfi ("Basis", "string"), loc)
adamc@251 836 val t' = (L'.TFfi ("Basis", "string"), loc)
adamc@251 837 val e = (L'.EPrim (Prim.String s), loc)
adamc@251 838 in
adamc@251 839 SOME (Env.pushENamed env x n t NONE s,
adamc@251 840 fm,
adamc@251 841 (L'.DVal (x, n, t', e, s), loc))
adamc@251 842 end
adamc@25 843 end
adamc@25 844
adamc@25 845 fun monoize env ds =
adamc@25 846 let
adamc@179 847 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
adamc@179 848 case monoDecl (env, fm) d of
adamc@179 849 NONE => (env, fm, ds)
adamc@179 850 | SOME (env, fm, d) =>
adamc@179 851 (env,
adamc@179 852 Fm.enter fm,
adamc@179 853 d :: Fm.decls fm @ ds))
adamc@179 854 (env, Fm.empty (CoreUtil.File.maxName ds + 1), []) ds
adamc@25 855 in
adamc@25 856 rev ds
adamc@25 857 end
adamc@25 858
adamc@25 859 end