Mercurial > urweb

annotate src/scriptcheck.sml @ 2057:f4a6ccb7937f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Allow Body tags inside cformTags This is required by Bootstrap. For example, see http://getbootstrap.com/components/#alerts-dismissible
author Sergey Mironov <grrwlf@gmail.com>
date Sun, 17 Aug 2014 18:28:37 +0000
parents a9159911c3ba
children 3dd041b00087
rev   line source
adamc@643 1 (* Copyright (c) 2009, Adam Chlipala
adamc@643 2 * All rights reserved.
adamc@643 3 *
adamc@643 4 * Redistribution and use in source and binary forms, with or without
adamc@643 5 * modification, are permitted provided that the following conditions are met:
adamc@643 6 *
adamc@643 7 * - Redistributions of source code must retain the above copyright notice,
adamc@643 8 * this list of conditions and the following disclaimer.
adamc@643 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@643 10 * this list of conditions and the following disclaimer in the documentation
adamc@643 11 * and/or other materials provided with the distribution.
adamc@643 12 * - The names of contributors may not be used to endorse or promote products
adamc@643 13 * derived from this software without specific prior written permission.
adamc@643 14 *
adamc@643 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@643 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@643 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@643 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@643 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@643 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@643 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@643 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@643 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@643 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@643 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@643 26 *)
adamc@643 27
adamc@643 28 structure ScriptCheck :> SCRIPT_CHECK = struct
adamc@643 29
adam@1845 30 open Mono
adamc@643 31
adamc@643 32 structure SS = BinarySetFn(struct
adamc@643 33 type ord_key = string
adamc@643 34 val compare = String.compare
adamc@643 35 end)
adamc@643 36 structure IS = IntBinarySet
adamc@643 37
adamc@693 38 val pushBasis = SS.addList (SS.empty,
adamc@693 39 ["new_channel",
adamc@693 40 "self"])
adamc@799 41
adamc@643 42 fun classify (ds, ps) =
adamc@643 43 let
adamc@855 44 val proto = Settings.currentProtocol ()
adamc@855 45
adamc@970 46 fun inString {needle, haystack} = String.isSubstring needle haystack
adamc@643 47
adam@1845 48 fun hasClient {basis, funcs, push} =
adam@1845 49 MonoUtil.Exp.exists {typ = fn _ => false,
adam@1845 50 exp = fn ERecv _ => push
adam@1845 51 | EFfiApp ("Basis", x, _) => SS.member (basis, x)
adam@1845 52 | EJavaScript _ => not push
adam@1845 53 | ENamed n => IS.member (funcs, n)
adam@1845 54 | _ => false}
adamc@643 55
adamc@693 56 fun decl ((d, _), (pull_ids, push_ids)) =
adamc@643 57 let
adam@1845 58 val hasClientPull = hasClient {basis = SS.empty, funcs = pull_ids, push = false}
adam@1845 59 val hasClientPush = hasClient {basis = pushBasis, funcs = push_ids, push = true}
adamc@643 60 in
adamc@643 61 case d of
adam@1845 62 DVal (_, n, _, e, _) => (if hasClientPull e then
adamc@693 63 IS.add (pull_ids, n)
adamc@693 64 else
adamc@693 65 pull_ids,
adamc@693 66 if hasClientPush e then
adamc@693 67 IS.add (push_ids, n)
adamc@693 68 else
adamc@693 69 push_ids)
adam@1845 70 | DValRec xes => (if List.exists (fn (_, _, _, e, _) => hasClientPull e) xes then
adamc@693 71 foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n))
adamc@693 72 pull_ids xes
adamc@693 73 else
adamc@693 74 pull_ids,
adam@1845 75 if List.exists (fn (_, _, _, e, _) => hasClientPush e) xes then
adamc@693 76 foldl (fn ((_, n, _, _, _), push_ids) => IS.add (push_ids, n))
adamc@693 77 push_ids xes
adamc@693 78 else
adamc@693 79 push_ids)
adamc@693 80 | _ => (pull_ids, push_ids)
adamc@643 81 end
adamc@643 82
adamc@693 83 val (pull_ids, push_ids) = foldl decl (IS.empty, IS.empty) ds
adamc@643 84
adamc@855 85 val foundBad = ref false
adamc@855 86
adam@1845 87 val all_ids = IS.union (pull_ids, push_ids)
adam@1845 88
adam@1845 89 val ps = map (fn n =>
adam@1845 90 (n, if IS.member (push_ids, n) then
adam@1845 91 (if not (#persistent proto) andalso not (!foundBad) then
adam@1845 92 (foundBad := true;
adam@1845 93 ErrorMsg.error ("This program needs server push, but the current protocol ("
adam@1845 94 ^ #name proto ^ ") doesn't support that."))
adam@1845 95 else
adam@1845 96 ();
adam@1845 97 ServerAndPullAndPush)
adam@1845 98 else if IS.member (pull_ids, n) then
adam@1845 99 ServerAndPull
adam@1845 100 else
adam@2056 101 ServerOnly, AnyDb)) (IS.listItems all_ids)
adamc@643 102 in
adamc@643 103 (ds, ps)
adamc@643 104 end
adamc@643 105
adamc@643 106 end
adamc@643 107