Mercurial > urweb

annotate src/shake.sml @ 709:0406e9cccb72

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
FOREIGN KEY, without ability to link NULL to NOT NULL (and with some lingering problems in row inference)
author Adam Chlipala <adamc@hcoop.net>
date Tue, 07 Apr 2009 18:47:47 -0400
parents d8217b4cb617
children f152f215a02c
rev   line source
adamc@23 1 (* Copyright (c) 2008, Adam Chlipala
adamc@23 2 * All rights reserved.
adamc@23 3 *
adamc@23 4 * Redistribution and use in source and binary forms, with or without
adamc@23 5 * modification, are permitted provided that the following conditions are met:
adamc@23 6 *
adamc@23 7 * - Redistributions of source code must retain the above copyright notice,
adamc@23 8 * this list of conditions and the following disclaimer.
adamc@23 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@23 10 * this list of conditions and the following disclaimer in the documentation
adamc@23 11 * and/or other materials provided with the distribution.
adamc@23 12 * - The names of contributors may not be used to endorse or promote products
adamc@23 13 * derived from this software without specific prior written permission.
adamc@23 14 *
adamc@23 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@23 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@23 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@23 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@23 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@23 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@23 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@23 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@23 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@23 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@23 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@23 26 *)
adamc@23 27
adamc@23 28 (* Remove unused definitions from a file *)
adamc@23 29
adamc@23 30 structure Shake :> SHAKE = struct
adamc@23 31
adamc@23 32 open Core
adamc@23 33
adamc@23 34 structure U = CoreUtil
adamc@23 35
adamc@23 36 structure IS = IntBinarySet
adamc@23 37 structure IM = IntBinaryMap
adamc@23 38
adamc@23 39 type free = {
adamc@23 40 con : IS.set,
adamc@23 41 exp : IS.set
adamc@23 42 }
adamc@23 43
adamc@338 44 val dummyt = (TRecord (CRecord ((KType, ErrorMsg.dummySpan), []), ErrorMsg.dummySpan), ErrorMsg.dummySpan)
adamc@247 45 val dummye = (EPrim (Prim.String ""), ErrorMsg.dummySpan)
adamc@247 46
adamc@23 47 fun shake file =
adamc@100 48 let
adamc@704 49 val usedVars = U.Exp.fold {kind = fn (_, st) => st,
adamc@704 50 con = fn (c, st as (es, cs)) =>
adamc@704 51 case c of
adamc@704 52 CNamed n => (es, IS.add (cs, n))
adamc@704 53 | _ => st,
adamc@704 54 exp = fn (e, st as (es, cs)) =>
adamc@704 55 case e of
adamc@704 56 ENamed n => (IS.add (es, n), cs)
adamc@704 57 | _ => st}
adamc@704 58
adamc@704 59 val (usedE, usedC, table_cs) =
adamc@248 60 List.foldl
adamc@704 61 (fn ((DExport (_, n), _), (usedE, usedC, table_cs)) => (IS.add (usedE, n), usedE, table_cs)
adamc@707 62 | ((DTable (_, _, c, _, pe, _, ce, _), _), (usedE, usedC, table_cs)) =>
adamc@704 63 let
adamc@707 64 val (usedE, usedC) = usedVars (usedE, usedC) pe
adamc@707 65 val (usedE, usedC) = usedVars (usedE, usedC) ce
adamc@704 66 in
adamc@704 67 (usedE, usedC, c :: table_cs)
adamc@704 68 end
adamc@704 69 | (_, acc) => acc) (IS.empty, IS.empty, []) file
adamc@23 70
adamc@163 71 val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef)
adamc@192 72 | ((DDatatype (_, n, _, xncs), _), (cdef, edef)) =>
adamc@163 73 (IM.insert (cdef, n, List.mapPartial #3 xncs), edef)
adamc@453 74 | ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], t, e)))
adamc@125 75 | ((DValRec vis, _), (cdef, edef)) =>
adamc@453 76 let
adamc@453 77 val all_ns = map (fn (_, n, _, _, _) => n) vis
adamc@453 78 in
adamc@453 79 (cdef, foldl (fn ((_, n, t, e, _), edef) =>
adamc@453 80 IM.insert (edef, n, (all_ns, t, e))) edef vis)
adamc@453 81 end
adamc@247 82 | ((DExport _, _), acc) => acc
adamc@707 83 | ((DTable (_, n, c, _, _, _, _, _), _), (cdef, edef)) =>
adamc@453 84 (cdef, IM.insert (edef, n, ([], c, dummye)))
adamc@338 85 | ((DSequence (_, n, _), _), (cdef, edef)) =>
adamc@453 86 (cdef, IM.insert (edef, n, ([], dummyt, dummye)))
adamc@461 87 | ((DDatabase _, _), acc) => acc
adamc@461 88 | ((DCookie (_, n, c, _), _), (cdef, edef)) =>
adamc@461 89 (cdef, IM.insert (edef, n, ([], c, dummye))))
adamc@100 90 (IM.empty, IM.empty) file
adamc@23 91
adamc@100 92 fun kind (_, s) = s
adamc@23 93
adamc@100 94 fun con (c, s) =
adamc@100 95 case c of
adamc@100 96 CNamed n =>
adamc@100 97 if IS.member (#con s, n) then
adamc@100 98 s
adamc@100 99 else
adamc@100 100 let
adamc@100 101 val s' = {con = IS.add (#con s, n),
adamc@100 102 exp = #exp s}
adamc@100 103 in
adamc@100 104 case IM.find (cdef, n) of
adamc@100 105 NONE => s'
adamc@163 106 | SOME cs => foldl (fn (c, s') => shakeCon s' c) s' cs
adamc@100 107 end
adamc@100 108 | _ => s
adamc@23 109
adamc@100 110 and shakeCon s = U.Con.fold {kind = kind, con = con} s
adamc@23 111
adamc@100 112 fun exp (e, s) =
adamc@607 113 let
adamc@607 114 fun check n =
adamc@607 115 if IS.member (#exp s, n) then
adamc@607 116 s
adamc@607 117 else
adamc@607 118 let
adamc@607 119 val s' = {exp = IS.add (#exp s, n),
adamc@607 120 con = #con s}
adamc@607 121 in
adamc@607 122 (*print ("Need " ^ Int.toString n ^ "\n");*)
adamc@607 123 case IM.find (edef, n) of
adamc@607 124 NONE => s'
adamc@607 125 | SOME (ns, t, e) =>
adamc@607 126 let
adamc@607 127 val s' = shakeExp (shakeCon s' t) e
adamc@607 128 in
adamc@607 129 foldl (fn (n, s') => exp (ENamed n, s')) s' ns
adamc@607 130 end
adamc@607 131 end
adamc@607 132 in
adamc@607 133 case e of
adamc@607 134 ENamed n => check n
adamc@609 135 | EServerCall (n, _, _, _) => check n
adamc@607 136 | _ => s
adamc@607 137 end
adamc@23 138
adamc@100 139 and shakeExp s = U.Exp.fold {kind = kind, con = con, exp = exp} s
adamc@100 140
adamc@704 141 val s = {con = usedC, exp = usedE}
adamc@109 142
adamc@704 143 val s = IS.foldl (fn (n, s) =>
adamc@704 144 case IM.find (edef, n) of
adamc@704 145 NONE => raise Fail "Shake: Couldn't find 'val'"
adamc@704 146 | SOME (ns, t, e) =>
adamc@704 147 let
adamc@704 148 val s = shakeExp (shakeCon s t) e
adamc@704 149 in
adamc@704 150 foldl (fn (n, s) => exp (ENamed n, s)) s ns
adamc@704 151 end) s usedE
adamc@248 152
adamc@248 153 val s = foldl (fn (c, s) => shakeCon s c) s table_cs
adamc@100 154 in
adamc@100 155 List.filter (fn (DCon (_, n, _, _), _) => IS.member (#con s, n)
adamc@192 156 | (DDatatype (_, n, _, _), _) => IS.member (#con s, n)
adamc@109 157 | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
adamc@125 158 | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis
adamc@247 159 | (DExport _, _) => true
adamc@271 160 | (DTable _, _) => true
adamc@338 161 | (DSequence _, _) => true
adamc@461 162 | (DDatabase _, _) => true
adamc@461 163 | (DCookie _, _) => true) file
adamc@100 164 end
adamc@23 165
adamc@23 166 end