src/Pure/Thy/thm_deps.ML
author wenzelm
Mon Nov 02 21:05:47 2009 +0100 (2009-11-02)
changeset 33391 91b9da2a7b44
parent 33170 dd6d8d1f70d2
child 33642 d983509dbf31
permissions -rw-r--r--
structure Thm_Deps;
     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: 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 thms =
    19   let
    20     fun add_dep ("", _, _) = I
    21       | add_dep (name, _, PBody {thms = thms', ...}) =
    22           let
    23             val prefix = #1 (Library.split_last (Long_Name.explode name));
    24             val session =
    25               (case prefix of
    26                 a :: _ =>
    27                   (case ThyInfo.lookup_theory 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 => PureThy.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.get_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 thms =
    63       fold (add_facts o PureThy.facts_of) thys []
    64       |> sort_distinct (string_ord o pairself #1);
    65 
    66     val tab =
    67       Proofterm.fold_body_thms
    68         (fn (a, prop, _) => a <> "" ? Symtab.insert_list (op =) (a, prop))
    69         (map (Proofterm.strip_thm o Thm.proof_body_of o #1 o #2) thms) Symtab.empty;
    70 
    71     fun is_unused (a, th) =
    72       not (member (op aconv) (Symtab.lookup_list tab a) (Thm.prop_of th));
    73 
    74     (* groups containing at least one used theorem *)
    75     val used_groups = fold (fn (a, (th, _, group)) =>
    76       if is_unused (a, th) then I
    77       else
    78         (case group of
    79           NONE => I
    80         | SOME grp => Inttab.update (grp, ()))) thms Inttab.empty;
    81     val (thms', _) = fold (fn (a, (th, concealed, group)) => fn q as (thms, grps') =>
    82       if member (op =) [Thm.theoremK, Thm.generatedK, Thm.lemmaK, Thm.corollaryK, Thm.axiomK]
    83         (Thm.get_kind th) andalso not concealed andalso is_unused (a, th)
    84       then
    85         (case group of
    86            NONE => ((a, th) :: thms, grps')
    87          | SOME grp =>
    88              (* do not output theorem if another theorem in group has been used *)
    89              if Inttab.defined used_groups grp then q
    90              (* output at most one unused theorem per group *)
    91              else if Inttab.defined grps' grp then q
    92              else ((a, th) :: thms, Inttab.update (grp, ()) grps'))
    93       else q) thms ([], Inttab.empty)
    94   in rev thms' end;
    95 
    96 end;
    97