1 (* Title: Pure/Isar/typedecl.ML |
1 (* Title: Pure/Isar/typedecl.ML |
2 Author: Makarius |
2 Author: Makarius |
3 |
3 |
4 Type declarations (within the object logic). |
4 Type declarations (with object-logic arities) and type abbreviations. |
5 *) |
5 *) |
6 |
6 |
7 signature TYPEDECL = |
7 signature TYPEDECL = |
8 sig |
8 sig |
9 val read_constraint: Proof.context -> string option -> sort |
9 val read_constraint: Proof.context -> string option -> sort |
10 val basic_typedecl: binding * int * mixfix -> local_theory -> string * local_theory |
10 val basic_typedecl: binding * int * mixfix -> local_theory -> string * local_theory |
11 val typedecl: binding * (string * sort) list * mixfix -> local_theory -> typ * local_theory |
11 val typedecl: binding * (string * sort) list * mixfix -> local_theory -> typ * local_theory |
12 val typedecl_global: binding * (string * sort) list * mixfix -> theory -> typ * theory |
12 val typedecl_global: binding * (string * sort) list * mixfix -> theory -> typ * theory |
|
13 val abbrev: binding * string list * mixfix -> typ -> local_theory -> string * local_theory |
|
14 val abbrev_cmd: binding * string list * mixfix -> string -> local_theory -> string * local_theory |
|
15 val abbrev_global: binding * string list * mixfix -> typ -> theory -> string * theory |
13 end; |
16 end; |
14 |
17 |
15 structure Typedecl: TYPEDECL = |
18 structure Typedecl: TYPEDECL = |
16 struct |
19 struct |
17 |
20 |
26 fun object_logic_arity name thy = |
29 fun object_logic_arity name thy = |
27 (case Object_Logic.get_base_sort thy of |
30 (case Object_Logic.get_base_sort thy of |
28 NONE => thy |
31 NONE => thy |
29 | SOME S => AxClass.axiomatize_arity (name, replicate (Sign.arity_number thy name) S, S) thy); |
32 | SOME S => AxClass.axiomatize_arity (name, replicate (Sign.arity_number thy name) S, S) thy); |
30 |
33 |
31 fun basic_typedecl (b, n, mx) lthy = |
34 fun basic_decl decl (b, n, mx) lthy = |
32 let val name = Local_Theory.full_name lthy b in |
35 let val name = Local_Theory.full_name lthy b in |
33 lthy |
36 lthy |
34 |> Local_Theory.theory (Sign.add_types [(b, n, NoSyn)] #> object_logic_arity name) |
37 |> Local_Theory.theory (decl name) |
35 |> Local_Theory.type_notation true Syntax.mode_default [(Type (name, replicate n dummyT), mx)] |
38 |> Local_Theory.type_notation true Syntax.mode_default [(Type (name, replicate n dummyT), mx)] |
36 |> Local_Theory.type_alias b name |
39 |> Local_Theory.type_alias b name |
37 |> pair name |
40 |> pair name |
38 end; |
41 end; |
39 |
42 |
|
43 fun basic_typedecl (b, n, mx) = |
|
44 basic_decl (fn name => Sign.add_types [(b, n, NoSyn)] #> object_logic_arity name) (b, n, mx); |
40 |
45 |
41 (* regular typedecl -- without dependencies on type parameters of the context *) |
|
42 |
46 |
43 fun typedecl (b, raw_args, mx) lthy = |
47 (* global type -- without dependencies on type parameters of the context *) |
|
48 |
|
49 fun global_type lthy (b, raw_args) = |
44 let |
50 let |
45 fun err msg = error (msg ^ " in type declaration " ^ quote (Binding.str_of b)); |
51 fun err msg = error (msg ^ " in type declaration " ^ quote (Binding.str_of b)); |
46 |
52 |
47 val _ = has_duplicates (eq_fst op =) raw_args andalso err "Duplicate parameters"; |
53 val _ = has_duplicates (eq_fst op =) raw_args andalso err "Duplicate parameters"; |
48 val args = map (TFree o ProofContext.check_tfree lthy) raw_args; |
54 val args = map (TFree o ProofContext.check_tfree lthy) raw_args; |
49 val T = Type (Local_Theory.full_name lthy b, args); |
55 val T = Type (Local_Theory.full_name lthy b, args); |
50 |
56 |
51 val bad_args = |
57 val bad_args = |
52 #2 (Term.dest_Type (Logic.type_map (singleton (Variable.polymorphic lthy)) T)) |
58 #2 (Term.dest_Type (Logic.type_map (singleton (Variable.polymorphic lthy)) T)) |
53 |> filter_out Term.is_TVar; |
59 |> filter_out Term.is_TVar; |
54 val _ = not (null bad_args) andalso |
60 val _ = null bad_args orelse |
55 err ("Locally fixed type arguments " ^ |
61 err ("Locally fixed type arguments " ^ |
56 commas_quote (map (Syntax.string_of_typ lthy) bad_args)); |
62 commas_quote (map (Syntax.string_of_typ lthy) bad_args)); |
57 in |
63 in T end; |
|
64 |
|
65 |
|
66 (* type declarations *) |
|
67 |
|
68 fun typedecl (b, raw_args, mx) lthy = |
|
69 let val T = global_type lthy (b, raw_args) in |
58 lthy |
70 lthy |
59 |> basic_typedecl (b, length args, mx) |
71 |> basic_typedecl (b, length raw_args, mx) |
60 |> snd |
72 |> snd |
61 |> Variable.declare_typ T |
73 |> Variable.declare_typ T |
62 |> pair T |
74 |> pair T |
63 end; |
75 end; |
64 |
76 |
65 fun typedecl_global decl = |
77 fun typedecl_global decl = |
66 Theory_Target.init NONE |
78 Theory_Target.init NONE |
67 #> typedecl decl |
79 #> typedecl decl |
68 #> Local_Theory.exit_result_global Morphism.typ; |
80 #> Local_Theory.exit_result_global Morphism.typ; |
69 |
81 |
|
82 |
|
83 (* type abbreviations *) |
|
84 |
|
85 fun gen_abbrev prep_typ (b, vs, mx) raw_rhs lthy = |
|
86 let |
|
87 val Type (name, _) = global_type lthy (b, map (rpair dummyS) vs); |
|
88 val rhs = prep_typ lthy raw_rhs |
|
89 handle ERROR msg => cat_error msg ("in type abbreviation " ^ quote (Binding.str_of b)); |
|
90 in |
|
91 lthy |
|
92 |> basic_decl (fn _ => Sign.add_tyabbrs_i [(b, vs, rhs, NoSyn)]) (b, length vs, mx) |
|
93 |> snd |
|
94 |> pair name |
|
95 end; |
|
96 |
|
97 val abbrev = gen_abbrev ProofContext.cert_typ; |
|
98 val abbrev_cmd = gen_abbrev ProofContext.read_typ; |
|
99 |
|
100 fun abbrev_global decl rhs = |
|
101 Theory_Target.init NONE |
|
102 #> abbrev decl rhs |
|
103 #> Local_Theory.exit_result_global (K I); |
|
104 |
70 end; |
105 end; |
71 |
106 |