Mercurial > urweb

annotate src/effectize.sml @ 733:15ddd64a5113

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add more buttons to demo, to avoid effectful GET
author Adam Chlipala <adamc@hcoop.net>
date Thu, 16 Apr 2009 15:38:01 -0400
parents 5819fb63c93a
children 5ccb67665d05
rev   line source
adamc@732 1 (* Copyright (c) 2009, Adam Chlipala
adamc@732 2 * All rights reserved.
adamc@732 3 *
adamc@732 4 * Redistribution and use in source and binary forms, with or without
adamc@732 5 * modification, are permitted provided that the following conditions are met:
adamc@732 6 *
adamc@732 7 * - Redistributions of source code must retain the above copyright notice,
adamc@732 8 * this list of conditions and the following disclaimer.
adamc@732 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@732 10 * this list of conditions and the following disclaimer in the documentation
adamc@732 11 * and/or other materials provided with the distribution.
adamc@732 12 * - The names of contributors may not be used to endorse or promote products
adamc@732 13 * derived from this software without specific prior written permission.
adamc@732 14 *
adamc@732 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@732 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@732 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@732 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@732 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@732 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@732 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@732 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@732 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@732 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@732 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@732 26 *)
adamc@732 27
adamc@732 28 structure Effective :> EFFECTIZE = struct
adamc@732 29
adamc@732 30 open Core
adamc@732 31
adamc@732 32 structure U = CoreUtil
adamc@732 33
adamc@732 34 structure IM = IntBinaryMap
adamc@732 35 structure SS = BinarySetFn(struct
adamc@732 36 type ord_key = string
adamc@732 37 val compare = String.compare
adamc@732 38 end)
adamc@732 39
adamc@732 40 val effectful = ["dml", "nextval", "send"]
adamc@732 41 val effectful = SS.addList (SS.empty, effectful)
adamc@732 42
adamc@732 43 fun effectize file =
adamc@732 44 let
adamc@732 45 fun exp evs e =
adamc@732 46 case e of
adamc@732 47 EFfi ("Basis", s) => SS.member (effectful, s)
adamc@732 48 | EFfiApp ("Basis", s, _) => SS.member (effectful, s)
adamc@732 49 | ENamed n => IM.inDomain (evs, n)
adamc@732 50 | EServerCall (n, _, _, _) => IM.inDomain (evs, n)
adamc@732 51 | _ => false
adamc@732 52
adamc@732 53 fun couldWrite evs = U.Exp.exists {kind = fn _ => false,
adamc@732 54 con = fn _ => false,
adamc@732 55 exp = exp evs}
adamc@732 56
adamc@732 57 fun doDecl (d, evs) =
adamc@732 58 case #1 d of
adamc@732 59 DVal (x, n, t, e, s) =>
adamc@732 60 (d, if couldWrite evs e then
adamc@732 61 IM.insert (evs, n, (#2 d, s))
adamc@732 62 else
adamc@732 63 evs)
adamc@732 64 | DValRec vis =>
adamc@732 65 let
adamc@732 66 fun oneRound evs =
adamc@732 67 foldl (fn ((_, n, _, e, s), (changed, evs)) =>
adamc@732 68 if couldWrite evs e andalso not (IM.inDomain (evs, n)) then
adamc@732 69 (true, IM.insert (evs, n, (#2 d, s)))
adamc@732 70 else
adamc@732 71 (changed, evs)) (false, evs) vis
adamc@732 72
adamc@732 73 fun loop evs =
adamc@732 74 let
adamc@732 75 val (b, evs) = oneRound evs
adamc@732 76 in
adamc@732 77 if b then
adamc@732 78 loop evs
adamc@732 79 else
adamc@732 80 evs
adamc@732 81 end
adamc@732 82 in
adamc@732 83 (d, loop evs)
adamc@732 84 end
adamc@732 85 | DExport (Link, n) =>
adamc@732 86 (case IM.find (evs, n) of
adamc@732 87 NONE => ()
adamc@732 88 | SOME (loc, s) => ErrorMsg.errorAt loc ("A link (" ^ s ^ ") could cause side effects; try implementing it with a form instead");
adamc@732 89 (d, evs))
adamc@732 90 | DExport (Action _, n) =>
adamc@732 91 ((DExport (Action (if IM.inDomain (evs, n) then
adamc@732 92 ReadWrite
adamc@732 93 else
adamc@732 94 ReadOnly), n), #2 d),
adamc@732 95 evs)
adamc@732 96 | DExport (Rpc _, n) =>
adamc@732 97 ((DExport (Rpc (if IM.inDomain (evs, n) then
adamc@732 98 ReadWrite
adamc@732 99 else
adamc@732 100 ReadOnly), n), #2 d),
adamc@732 101 evs)
adamc@732 102 | _ => (d, evs)
adamc@732 103
adamc@732 104 val (file, _) = ListUtil.foldlMap doDecl IM.empty file
adamc@732 105 in
adamc@732 106 file
adamc@732 107 end
adamc@732 108
adamc@732 109 end