Ur/Web: src/monoize.sml comparison

comparison src/monoize.sml @ 1682:ac141fbb313a

'ORDER BY RANDOM' (based on a patch from Ron de Bruijn)

author	Adam Chlipala <adam@chlipala.net>
date	Thu, 02 Feb 2012 11:40:10 -0500
parents	5b2c7b9f6017
children	a7b70c7b3f1a

comparison

equal deleted inserted replaced

-:e8a84494d2c0
+:ac141fbb313a
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 val (r, fs') = ListPair.foldr (fn ((_, t), (x, n, _), (r, fs')) =>
 ((x, n, SOME t) :: r,
 SM.insert (fs', x, n))) ([], SM.empty) (r, fs)
 in
 pvars := RM.insert (!pvars, r', (n, fs));
 pvarDefs := (L'.DDatatype [("$poly" ^ Int.toString n, n, map (fn (x, n, t) => (x, n, SOME t)) fs)], loc)
 :: !pvarDefs;
 pvarOldDefs := (n, r) :: !pvarOldDefs;
 (n, fs)
 end
 | SOME v => v
 SOME r => (L'.TDatatype (n, r), loc)
 | NONE =>
 let
 val r = ref (L'.Default, [])
 val (_, xs, xncs) = Env.lookupDatatype env n
 val dtmap' = IM.insert (dtmap, n, r)
 val xncs = map (fn (x, n, to) => (x, n, Option.map (mt env dtmap') to)) xncs
 in
 case xs of
 [] =>(r := (ElabUtil.classifyDatatype xncs, xncs);
 (L'.TDatatype (n, r), loc))
 branches,
 {disc = dom,
 result = ran}), loc)), loc),
 "")], loc),
 fm)
 end
 val (fm, n) = Fm.lookup fm fk i makeDecl
 in
 ((L'.EApp ((L'.ENamed n, loc), e), loc), fm)
 end
 val (body, fm) = fooify fm ((L'.ERel 0, loc), t)
 in
 ((L'.ECase (e,
 [((L'.PNone t, loc),
 (L'.EPrim (Prim.String "None"), loc)),
 ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc),
 (L'.EStrcat ((L'.EPrim (Prim.String "Some/"), loc),
 body), loc))],
 {disc = tAll,
 result = (L'.TFfi ("Basis", "string"), loc)}), loc),
 val dom = ordTy t
 in
 ((L'.EAbs ("f", dom, dom,
 (L'.ERel 0, loc)), loc), fm)
 end
 | L.ECApp ((L.EFfi ("Basis", "show"), _), t) =>
 let
 val t = monoType env t
 val s = (L'.TFfi ("Basis", "string"), loc)
 in
 sc ""),
 ((L'.PWild, loc),
 strcat [sc " WHERE ", gf "Where"])],
 {disc = s,
 result = s}), loc),
 if List.all (fn (x, xts) =>
 case List.find (fn (x', _) => x' = x) grouped of
 NONE => List.null xts
 | SOME (_, xts') =>
 List.all (fn (x, _) =>
 | L.ECApp ((L.EFfi ("Basis", "sql_subset_all"), _), _) =>
 ((L'.ERecord [], loc), fm)
 | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_subset_concat"),
 _), _), _), _), _), _), _), _) =>
 let
 val un = (L'.TRecord [], loc)
 in
 ((L'.EAbs ("_", un, (L'.TFun (un, un), loc),
 (L'.EAbs ("_", un, un,
 (L'.ERecord [], loc)), loc)), loc),
 fm)
 fm)
 end
 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) =>
 ((L'.EPrim (Prim.String ""), loc), fm)
+| L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_random"), _), _), _), _) =>
+((L'.EPrim (Prim.String (#randomFunction (Settings.currentDbms ()) ^ "()")), loc), fm)
 | L.ECApp (
 (L.ECApp (
 (L.ECApp (
 (L.EFfi ("Basis", "sql_order_by_Cons"), _),
 _), _),
 (L'.EPrim (Prim.String "MIN"), loc)), loc)), loc),
 fm)
 | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm)
 | L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm)
 | L.ECApp (
 (L.ECApp (
 (L.ECApp (
 (L.ECApp (
 (L.EFfi ("Basis", "sql_nfunc"), _),
 _), _),
 _), _),
 _), _),
 _) =>
 let
 val s = (L'.TFfi ("Basis", "string"), loc)
 fun sc s = (L'.EPrim (Prim.String s), loc)
 in
 ((L'.EAbs ("u", (L'.TRecord [], loc), (L'.TFun (s, s), loc),
 (L'.EAbs ("x", s, s,
 (L'.ERel 0, loc)), loc)), loc),
 fm)
 end
 | L.ECApp (
 (L.ECApp (
 (L.ECApp (
 (L.ECApp (
 (L.ECApp (
 case attrs of
 [] => (onload, onunload, acc)
 | ("Onload", e, _) :: rest => findOnload (rest, SOME e, onunload, acc)
 | ("Onunload", e, _) :: rest => findOnload (rest, onload, SOME e, acc)
 | x :: rest => findOnload (rest, onload, onunload, x :: acc)
 val (onload, onunload, attrs) = findOnload (attrs, NONE, NONE, [])
 val (class, fm) = monoExp (env, st, fm) class
 val (dynClass, fm) = monoExp (env, st, fm) dynClass
 fun inTag tag = case targs of
 						(L.CRecord (_, ctx), _) :: _ =>
 						List.exists (fn ((L.CName tag', _), _) => tag' = tag
 | _ => false) ctx
 | _ => false
 val tag = if inTag "Tr" then
 					  "tr"
 else if inTag "Table" then
 					  "table"
 else
 (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc),
 (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc),
 				 fm)
 | _ => raise Fail "Monoize: Bad dyn attributes"
 			end
 | "submit" => normal ("input type=\"submit\"", NONE, NONE)
 | "image" => normal ("input type=\"image\"", NONE, NONE)
 | "button" => normal ("input type=\"submit\"", NONE, NONE)
 | "hidden" => input "hidden"
 case #1 d of
 L.DDatabase s =>
 let
 val (nExp, fm) = Fm.freshName fm
 val (nIni, fm) = Fm.freshName fm
 val dExp = L'.DVal ("expunger",
 nExp,
 (L'.TFun (client, unit), loc),
 (L'.EAbs ("cli", client, unit, expunger ()), loc),
 "expunger")

Mercurial > urweb

comparison src/monoize.sml @ 1682:ac141fbb313a