193 lines
6.6 KiB
Standard ML
193 lines
6.6 KiB
Standard ML
(*
|
|
* Copyright 2014, NICTA
|
|
*
|
|
* This software may be distributed and modified according to the terms of
|
|
* the BSD 2-Clause license. Note that NO WARRANTY is provided.
|
|
* See "LICENSE_BSD2.txt" for details.
|
|
*
|
|
* @TAG(NICTA_BSD)
|
|
*)
|
|
|
|
signature PROOF_COUNT =
|
|
sig
|
|
|
|
datatype lemmaT = Lemma of string | Declare of string
|
|
|
|
datatype transactionT = Start | Qed | Declaration | Qed_Global | Unknown
|
|
|
|
type count_report = (((transactionT * string) * string list * (Position.range)) list Symtab.table)
|
|
|
|
val get_size_report : unit -> count_report
|
|
|
|
val compute_sizes : count_report -> (lemmaT * Position.range) Symtab.table
|
|
|
|
end
|
|
|
|
structure Proof_Count : PROOF_COUNT =
|
|
struct
|
|
|
|
datatype transactionT = Start | Qed | Declaration | Qed_Global | Unknown
|
|
|
|
type count_report = (((transactionT * string) * string list * (Position.range)) list Symtab.table)
|
|
|
|
val transactions = Synchronized.var "hooked" (Symtab.empty : ((transactionT * string) * string list * (Position.range)) list Symtab.table)
|
|
|
|
fun get_transactionT k =
|
|
if Keyword.is_theory_goal k orelse Keyword.is_proof_goal k then Start
|
|
else if Keyword.is_qed k then Qed
|
|
else if Keyword.is_qed_global k then Qed_Global
|
|
else if member (op =) (Keyword.command_tags k) "thy_decl" orelse k = "lemmas" then Declaration
|
|
else Unknown
|
|
|
|
fun needs_hook k = case get_transactionT k of Unknown => false
|
|
| _ => if k = "lemmas" orelse k = "by" then false else true
|
|
|
|
(*We explicitly ignore the "real" fact names because this is not what's given in the dependency analysis.*)
|
|
(*The "name" tag in the thm is what is picked up by the kernel for creating the proof_bodies*)
|
|
fun add_new_lemmas thy thy' beg fin trans =
|
|
let
|
|
val file = Position.file_of beg
|
|
|> the_default ""
|
|
val prev_facts = Global_Theory.facts_of thy;
|
|
val facts = Global_Theory.facts_of thy';
|
|
val nms = (Facts.dest_static false [prev_facts] facts);
|
|
val realnms = map (fn (_,thms) => filter Thm.has_name_hint thms |> map Thm.get_name_hint) nms |> flat
|
|
in
|
|
Synchronized.change transactions (Symtab.map_default (file,[]) (cons ((get_transactionT trans,trans),realnms,(beg,fin)))) end
|
|
|
|
|
|
val _ =
|
|
Outer_Syntax.command @{command_keyword "by"} "terminal backward proof"
|
|
((fn toks =>
|
|
let
|
|
val (beg,fin) = (Token.pos_of (hd toks),Token.pos_of (List.last toks))
|
|
val file = Position.file_of beg |> the_default ""
|
|
val _ = Synchronized.change transactions (Symtab.map_default (file,[]) (cons ((Qed,"by"),[],(beg,fin))))
|
|
in
|
|
(Method.parse -- Scan.option Method.parse >> Isar_Cmd.terminal_proof) toks
|
|
end))
|
|
|
|
fun wrap_lthy' ttyp parser toks =
|
|
let
|
|
val (flthy,toks') = parser toks
|
|
in
|
|
((fn b => fn lthy => let
|
|
val (beg,fin) = (Token.pos_of (hd toks),Token.pos_of (List.last toks))
|
|
val lthy' = flthy b lthy
|
|
val _ = add_new_lemmas (Proof_Context.theory_of lthy) (Proof_Context.theory_of lthy') beg fin ttyp
|
|
in
|
|
lthy' end),toks') end
|
|
|
|
fun theorems kind =
|
|
Parse_Spec.name_facts -- Parse.for_fixes
|
|
>> (fn (facts, fixes) => #2 oo Specification.theorems_cmd kind facts fixes);
|
|
|
|
val _ =
|
|
Outer_Syntax.local_theory' @{command_keyword "lemmas"} "define lemmas" (wrap_lthy' "lemmas" (theorems Thm.lemmaK));
|
|
|
|
fun get_size_report () = Synchronized.value transactions
|
|
|
|
(* Move to library? *)
|
|
fun bracket_list leftbr rightbr superbr l =
|
|
let
|
|
fun err () = error ("Mismatched parenthesis: " ^ Position.here @{here})
|
|
|
|
fun bracket_list_aux stack pairs extras [] =
|
|
if null stack then (rev pairs,rev extras) else err ()
|
|
|
|
| bracket_list_aux stack pairs extras (x :: l) =
|
|
if leftbr x then bracket_list_aux (x :: stack) pairs extras l
|
|
else if rightbr x then
|
|
case stack of
|
|
(s :: stack') => bracket_list_aux stack' ((s,x) :: pairs) extras l
|
|
| _ => err ()
|
|
else if superbr x then bracket_list_aux [] ((List.last stack,x) :: pairs) extras l
|
|
else bracket_list_aux stack pairs (x :: extras) l
|
|
in
|
|
bracket_list_aux [] [] [] l
|
|
end
|
|
|
|
fun merge_duplicates ord merge =
|
|
let
|
|
fun merge_duplicates_aux (a :: b :: l) =
|
|
(case (ord (a,b)) of
|
|
EQUAL => merge_duplicates_aux ((merge a b) :: l)
|
|
| GREATER => error "Merging duplicates requires sorted list"
|
|
| _ => a :: (merge_duplicates_aux (b :: l)))
|
|
|
|
| merge_duplicates_aux x = x
|
|
in
|
|
merge_duplicates_aux
|
|
end
|
|
|
|
|
|
fun to_tuple pos = (Position.line_of pos, Position.offset_of pos)
|
|
|
|
fun pos_ord (pos1,pos2) = (prod_ord (option_ord int_ord) (option_ord int_ord)) (to_tuple pos1,to_tuple pos2)
|
|
|
|
datatype lemmaT = Lemma of string | Declare of string
|
|
|
|
|
|
fun compute_sizes (transactions) =
|
|
let
|
|
|
|
fun trans_less (Start,Qed) = true
|
|
| trans_less (Start,Declaration) = true
|
|
| trans_less (Qed,Declaration) = true
|
|
| trans_less (Start,Qed_Global) = true
|
|
| trans_less (Qed_Global,Declaration) = true
|
|
| trans_less _ = false
|
|
|
|
fun do_prod (((trans,_),_,(st1,_)),((trans',_),_,(st2,_))) = ((st1,trans),(st2,trans'))
|
|
|
|
val ord = (prod_ord pos_ord (make_ord trans_less)) o do_prod
|
|
|
|
fun proc_entry (_,trans) =
|
|
let
|
|
val _ = map (fn ((Unknown,_),_,_) =>
|
|
error "Unexpected Unknown transaction in count report"
|
|
| _ => ()) trans
|
|
|
|
val sorted_transactions = sort ord trans
|
|
|> merge_duplicates ord (fn (t,nms,s) => fn (_,nms',_) => (t,merge (op =) (nms,nms'),s))
|
|
|
|
val (paired,singles) = bracket_list
|
|
(fn ((t,_),_,_) => t = Start)
|
|
(fn ((t,_),_,_) => t = Qed)
|
|
(fn ((t,_),_,_) => t = Qed_Global)
|
|
sorted_transactions
|
|
|
|
fun fix_range ((x,xs,(st1,_)),(_,ys,(_,fin2))) = (x,xs @ ys,(st1,fin2))
|
|
in
|
|
(map fix_range paired) @ singles end
|
|
|
|
fun translate_trans t nm = case t of Start => Lemma nm
|
|
| Declaration => Declare nm
|
|
| _ => error "Unexpected transaction type"
|
|
in
|
|
fold (append o proc_entry) (Symtab.dest transactions) []
|
|
|> map (fn (t,facts,range) => map (rpair (t,range)) facts)
|
|
|> flat
|
|
|> Symtab.make_list
|
|
|> Symtab.map (fn _ => fn k => find_first (fn (_,(p,p')) => Option.isSome (Position.line_of p) andalso Option.isSome (Position.line_of p')) k |> the_default (hd k))
|
|
|> Symtab.delete_safe ""
|
|
|> Symtab.map (fn _ => fn ((t,nm),range) => (translate_trans t nm,range))
|
|
end
|
|
|
|
(*FIXME: Redundant?*)
|
|
val _ = Toplevel.add_hook (fn trans => fn state => fn state' =>
|
|
if needs_hook (Toplevel.name_of trans) then
|
|
(let
|
|
val pos = Toplevel.pos_of trans
|
|
val name = Toplevel.name_of trans
|
|
|
|
val thy = Toplevel.theory_of state
|
|
val thy' = Toplevel.theory_of state'
|
|
|
|
in
|
|
add_new_lemmas thy thy' pos pos name end)
|
|
else ())
|
|
|
|
|
|
end
|