src/Pure/Thy/thm_deps.ML
author berghofe
Sat Jan 15 12:47:52 2011 +0100 (2011-01-15)
changeset 41565 9718c32f9c4e
parent 41489 8e2b8649507d
child 42473 aca720fb3936
permissions -rw-r--r--
unused_thms no longer compares propositions, since this is no longer needed
and did not work properly any longer after the addition of class constraints
to propositions.
     1 (*  Title:      Pure/Thy/thm_deps.ML
     2     Author:     Stefan Berghofer, TU Muenchen
     3 
     4 Visualize dependencies of theorems.
     5 *)
     6 
     7 signature THM_DEPS =
     8 sig
     9   val thm_deps: theory -> thm list -> unit
    10   val unused_thms: theory list * theory list -> (string * thm) list
    11 end;
    12 
    13 structure Thm_Deps: THM_DEPS =
    14 struct
    15 
    16 (* thm_deps *)
    17 
    18 fun thm_deps thy thms =
    19   let
    20     fun add_dep ("", _, _) = I
    21       | add_dep (name, _, PBody {thms = thms', ...}) =
    22           let
    23             val prefix = #1 (split_last (Long_Name.explode name));
    24             val session =
    25               (case prefix of
    26                 a :: _ =>
    27                   (case try (Context.get_theory thy) a of
    28                     SOME thy =>
    29                       (case Present.session_name thy of
    30                         "" => []
    31                       | session => [session])
    32                   | NONE => [])
    33                | _ => ["global"]);
    34             val parents = filter_out (fn s => s = "") (map (#1 o #2) thms');
    35             val entry =
    36               {name = Long_Name.base_name name,
    37                ID = name,
    38                dir = space_implode "/" (session @ prefix),
    39                unfold = false,
    40                path = "",
    41                parents = parents};
    42           in cons entry end;
    43     val deps = Proofterm.fold_body_thms add_dep (map Thm.proof_body_of thms) [];
    44   in Present.display_graph (sort_wrt #ID deps) end;
    45 
    46 
    47 (* unused_thms *)
    48 
    49 fun unused_thms (base_thys, thys) =
    50   let
    51     fun add_fact space (name, ths) =
    52       if exists (fn thy => Global_Theory.defined_fact thy name) base_thys then I
    53       else
    54         let val {concealed, group, ...} = Name_Space.the_entry space name in
    55           fold_rev (fn th =>
    56             (case Thm.derivation_name th of
    57               "" => I
    58             | a => cons (a, (th, concealed, group)))) ths
    59         end;
    60     fun add_facts facts = Facts.fold_static (add_fact (Facts.space_of facts)) facts;
    61 
    62     val new_thms =
    63       fold (add_facts o Global_Theory.facts_of) thys []
    64       |> sort_distinct (string_ord o pairself #1);
    65 
    66     val used =
    67       Proofterm.fold_body_thms
    68         (fn (a, _, _) => a <> "" ? Symtab.update (a, ()))
    69         (map (Proofterm.strip_thm o Thm.proof_body_of o #1 o #2) new_thms) Symtab.empty;
    70 
    71     fun is_unused a = not (Symtab.defined used a);
    72 
    73     (* groups containing at least one used theorem *)
    74     val used_groups = fold (fn (a, (_, _, group)) =>
    75       if is_unused a then I
    76       else
    77         (case group of
    78           NONE => I
    79         | SOME grp => Inttab.update (grp, ()))) new_thms Inttab.empty;
    80 
    81     val (thms', _) = fold (fn (a, (th, concealed, group)) => fn q as (thms, seen_groups) =>
    82       if not concealed andalso
    83         member (op =) [Thm.theoremK, Thm.lemmaK, Thm.corollaryK] (Thm.get_kind th) andalso
    84         is_unused a
    85       then
    86         (case group of
    87            NONE => ((a, th) :: thms, seen_groups)
    88          | SOME grp =>
    89              if Inttab.defined used_groups grp orelse
    90                Inttab.defined seen_groups grp then q
    91              else ((a, th) :: thms, Inttab.update (grp, ()) seen_groups))
    92       else q) new_thms ([], Inttab.empty);
    93   in rev thms' end;
    94 
    95 end;
    96