|
1 (* Title: find_consts.ML |
|
2 Author: Timothy Bourke and Gerwin Klein, NICTA |
|
3 |
|
4 Hoogle-like (http://www-users.cs.york.ac.uk/~ndm/hoogle) searching by type |
|
5 over constants, but matching is not fuzzy |
|
6 *) |
|
7 |
|
8 signature FIND_CONSTS = |
|
9 sig |
|
10 datatype criterion = Strict of string |
|
11 | Loose of string |
|
12 | Name of string |
|
13 |
|
14 val default_criteria : (bool * criterion) list ref |
|
15 |
|
16 val find_consts : Proof.context -> (bool * criterion) list -> unit |
|
17 end; |
|
18 |
|
19 structure FindConsts : FIND_CONSTS = |
|
20 struct |
|
21 |
|
22 datatype criterion = Strict of string |
|
23 | Loose of string |
|
24 | Name of string; |
|
25 |
|
26 val default_criteria = ref [(false, Name ".sko_")]; |
|
27 |
|
28 fun add_tye (_, (_, t)) n = size_of_typ t + n; |
|
29 |
|
30 fun matches_subtype thy typat = let |
|
31 val p = can (fn ty => Sign.typ_match thy (typat, ty) Vartab.empty); |
|
32 |
|
33 fun fs [] = false |
|
34 | fs (t::ts) = f t orelse fs ts |
|
35 |
|
36 and f (t as Type (_, ars)) = p t orelse fs ars |
|
37 | f t = p t; |
|
38 in f end; |
|
39 |
|
40 fun check_const p (nm, (ty, _)) = if p (nm, ty) |
|
41 then SOME (size_of_typ ty) |
|
42 else NONE; |
|
43 |
|
44 fun opt_not f (c as (_, (ty, _))) = if is_some (f c) |
|
45 then NONE else SOME (size_of_typ ty); |
|
46 |
|
47 fun find_consts ctxt raw_criteria = let |
|
48 val thy = ProofContext.theory_of ctxt; |
|
49 val low_ranking = 10000; |
|
50 |
|
51 fun make_pattern crit = ProofContext.read_term_pattern ctxt ("_::" ^ crit) |
|
52 |> type_of; |
|
53 |
|
54 fun make_match (Strict arg) = |
|
55 let val qty = make_pattern arg; in |
|
56 fn (_, (ty, _)) => let |
|
57 val tye = Sign.typ_match thy (qty, ty) Vartab.empty; |
|
58 val sub_size = Vartab.fold add_tye tye 0; |
|
59 in SOME sub_size end handle MATCH => NONE |
|
60 end |
|
61 |
|
62 | make_match (Loose arg) = |
|
63 check_const (matches_subtype thy (make_pattern arg) o snd) |
|
64 |
|
65 | make_match (Name arg) = check_const (match_string arg o fst); |
|
66 |
|
67 fun make_criterion (b, crit) = (if b then I else opt_not) (make_match crit); |
|
68 val criteria = map make_criterion ((!default_criteria) @ raw_criteria); |
|
69 |
|
70 val (_, consts) = (#constants o Consts.dest o Sign.consts_of) thy; |
|
71 |
|
72 fun filter_const (_, NONE) = NONE |
|
73 | filter_const (f, (SOME (c, r))) = Option.map |
|
74 (pair c o ((curry Int.min) r)) |
|
75 (f c); |
|
76 |
|
77 fun eval_entry c = foldl filter_const (SOME (c, low_ranking)) criteria; |
|
78 |
|
79 fun show (nm, ty) = let |
|
80 val ty' = Logic.unvarifyT ty; |
|
81 in |
|
82 (Pretty.block [Pretty.quote (Pretty.str nm), Pretty.fbrk, |
|
83 Pretty.str "::", Pretty.brk 1, |
|
84 Pretty.quote (Syntax.pretty_typ ctxt ty')]) |
|
85 end; |
|
86 in |
|
87 Symtab.fold (cons o eval_entry) consts [] |
|
88 |> map_filter I |
|
89 |> sort (rev_order o int_ord o pairself snd) |
|
90 |> map ((apsnd fst) o fst) |
|
91 |> map show |
|
92 |> Pretty.big_list "results:" |
|
93 |> Pretty.writeln |
|
94 end handle ERROR s => Output.error_msg s |
|
95 |
|
96 end; |
|
97 |