46 DEFL : thm |
46 DEFL : thm |
47 } |
47 } |
48 |
48 |
49 (* building types and terms *) |
49 (* building types and terms *) |
50 |
50 |
51 val udomT = @{typ udom} |
51 val udomT = \<^typ>\<open>udom\<close> |
52 val deflT = @{typ "udom defl"} |
52 val deflT = \<^typ>\<open>udom defl\<close> |
53 val udeflT = @{typ "udom u defl"} |
53 val udeflT = \<^typ>\<open>udom u defl\<close> |
54 fun emb_const T = Const (@{const_name emb}, T ->> udomT) |
54 fun emb_const T = Const (\<^const_name>\<open>emb\<close>, T ->> udomT) |
55 fun prj_const T = Const (@{const_name prj}, udomT ->> T) |
55 fun prj_const T = Const (\<^const_name>\<open>prj\<close>, udomT ->> T) |
56 fun defl_const T = Const (@{const_name defl}, Term.itselfT T --> deflT) |
56 fun defl_const T = Const (\<^const_name>\<open>defl\<close>, Term.itselfT T --> deflT) |
57 fun liftemb_const T = Const (@{const_name liftemb}, mk_upT T ->> mk_upT udomT) |
57 fun liftemb_const T = Const (\<^const_name>\<open>liftemb\<close>, mk_upT T ->> mk_upT udomT) |
58 fun liftprj_const T = Const (@{const_name liftprj}, mk_upT udomT ->> mk_upT T) |
58 fun liftprj_const T = Const (\<^const_name>\<open>liftprj\<close>, mk_upT udomT ->> mk_upT T) |
59 fun liftdefl_const T = Const (@{const_name liftdefl}, Term.itselfT T --> udeflT) |
59 fun liftdefl_const T = Const (\<^const_name>\<open>liftdefl\<close>, Term.itselfT T --> udeflT) |
60 |
60 |
61 fun mk_u_map t = |
61 fun mk_u_map t = |
62 let |
62 let |
63 val (T, U) = dest_cfunT (fastype_of t) |
63 val (T, U) = dest_cfunT (fastype_of t) |
64 val u_map_type = (T ->> U) ->> (mk_upT T ->> mk_upT U) |
64 val u_map_type = (T ->> U) ->> (mk_upT T ->> mk_upT U) |
65 val u_map_const = Const (@{const_name u_map}, u_map_type) |
65 val u_map_const = Const (\<^const_name>\<open>u_map\<close>, u_map_type) |
66 in |
66 in |
67 mk_capply (u_map_const, t) |
67 mk_capply (u_map_const, t) |
68 end |
68 end |
69 |
69 |
70 fun mk_cast (t, x) = |
70 fun mk_cast (t, x) = |
71 capply_const (udomT, udomT) |
71 capply_const (udomT, udomT) |
72 $ (capply_const (deflT, udomT ->> udomT) $ @{term "cast :: udom defl -> udom -> udom"} $ t) |
72 $ (capply_const (deflT, udomT ->> udomT) $ \<^term>\<open>cast :: udom defl -> udom -> udom\<close> $ t) |
73 $ x |
73 $ x |
74 |
74 |
75 (* manipulating theorems *) |
75 (* manipulating theorems *) |
76 |
76 |
77 (* proving class instances *) |
77 (* proving class instances *) |
90 |> fold (Variable.declare_typ o TFree) raw_args |
90 |> fold (Variable.declare_typ o TFree) raw_args |
91 val defl = prep_term tmp_ctxt raw_defl |
91 val defl = prep_term tmp_ctxt raw_defl |
92 val tmp_ctxt = tmp_ctxt |> Variable.declare_constraints defl |
92 val tmp_ctxt = tmp_ctxt |> Variable.declare_constraints defl |
93 |
93 |
94 val deflT = Term.fastype_of defl |
94 val deflT = Term.fastype_of defl |
95 val _ = if deflT = @{typ "udom defl"} then () |
95 val _ = if deflT = \<^typ>\<open>udom defl\<close> then () |
96 else error ("Not type defl: " ^ quote (Syntax.string_of_typ tmp_ctxt deflT)) |
96 else error ("Not type defl: " ^ quote (Syntax.string_of_typ tmp_ctxt deflT)) |
97 |
97 |
98 (*lhs*) |
98 (*lhs*) |
99 val lhs_tfrees = map (Proof_Context.check_tfree tmp_ctxt) raw_args |
99 val lhs_tfrees = map (Proof_Context.check_tfree tmp_ctxt) raw_args |
100 val full_tname = Sign.full_name thy tname |
100 val full_tname = Sign.full_name thy tname |
101 val newT = Type (full_tname, map TFree lhs_tfrees) |
101 val newT = Type (full_tname, map TFree lhs_tfrees) |
102 |
102 |
103 (*set*) |
103 (*set*) |
104 val set = @{term "defl_set :: udom defl => udom set"} $ defl |
104 val set = \<^term>\<open>defl_set :: udom defl => udom set\<close> $ defl |
105 |
105 |
106 (*pcpodef*) |
106 (*pcpodef*) |
107 fun tac1 ctxt = resolve_tac ctxt @{thms defl_set_bottom} 1 |
107 fun tac1 ctxt = resolve_tac ctxt @{thms defl_set_bottom} 1 |
108 fun tac2 ctxt = resolve_tac ctxt @{thms adm_defl_set} 1 |
108 fun tac2 ctxt = resolve_tac ctxt @{thms adm_defl_set} 1 |
109 val ((info, cpo_info, pcpo_info), thy) = thy |
109 val ((info, cpo_info, pcpo_info), thy) = thy |
122 val liftprj_eqn = |
122 val liftprj_eqn = |
123 Logic.mk_equals (liftprj_const newT, mk_u_map (prj_const newT)) |
123 Logic.mk_equals (liftprj_const newT, mk_u_map (prj_const newT)) |
124 val liftdefl_eqn = |
124 val liftdefl_eqn = |
125 Logic.mk_equals (liftdefl_const newT, |
125 Logic.mk_equals (liftdefl_const newT, |
126 Abs ("t", Term.itselfT newT, |
126 Abs ("t", Term.itselfT newT, |
127 mk_capply (@{const liftdefl_of}, defl_const newT $ Logic.mk_type newT))) |
127 mk_capply (\<^const>\<open>liftdefl_of\<close>, defl_const newT $ Logic.mk_type newT))) |
128 |
128 |
129 val name_def = Thm.def_binding tname |
129 val name_def = Thm.def_binding tname |
130 val emb_bind = (Binding.prefix_name "emb_" name_def, []) |
130 val emb_bind = (Binding.prefix_name "emb_" name_def, []) |
131 val prj_bind = (Binding.prefix_name "prj_" name_def, []) |
131 val prj_bind = (Binding.prefix_name "prj_" name_def, []) |
132 val defl_bind = (Binding.prefix_name "defl_" name_def, []) |
132 val defl_bind = (Binding.prefix_name "defl_" name_def, []) |
134 val liftprj_bind = (Binding.prefix_name "liftprj_" name_def, []) |
134 val liftprj_bind = (Binding.prefix_name "liftprj_" name_def, []) |
135 val liftdefl_bind = (Binding.prefix_name "liftdefl_" name_def, []) |
135 val liftdefl_bind = (Binding.prefix_name "liftdefl_" name_def, []) |
136 |
136 |
137 (*instantiate class rep*) |
137 (*instantiate class rep*) |
138 val lthy = thy |
138 val lthy = thy |
139 |> Class.instantiation ([full_tname], lhs_tfrees, @{sort domain}) |
139 |> Class.instantiation ([full_tname], lhs_tfrees, \<^sort>\<open>domain\<close>) |
140 val ((_, (_, emb_ldef)), lthy) = |
140 val ((_, (_, emb_ldef)), lthy) = |
141 Specification.definition NONE [] [] (emb_bind, emb_eqn) lthy |
141 Specification.definition NONE [] [] (emb_bind, emb_eqn) lthy |
142 val ((_, (_, prj_ldef)), lthy) = |
142 val ((_, (_, prj_ldef)), lthy) = |
143 Specification.definition NONE [] [] (prj_bind, prj_eqn) lthy |
143 Specification.definition NONE [] [] (prj_bind, prj_eqn) lthy |
144 val ((_, (_, defl_ldef)), lthy) = |
144 val ((_, (_, defl_ldef)), lthy) = |
194 |
194 |
195 |
195 |
196 (** outer syntax **) |
196 (** outer syntax **) |
197 |
197 |
198 val _ = |
198 val _ = |
199 Outer_Syntax.command @{command_keyword domaindef} "HOLCF definition of domains from deflations" |
199 Outer_Syntax.command \<^command_keyword>\<open>domaindef\<close> "HOLCF definition of domains from deflations" |
200 ((Parse.type_args_constrained -- Parse.binding) -- |
200 ((Parse.type_args_constrained -- Parse.binding) -- |
201 Parse.opt_mixfix -- (@{keyword "="} |-- Parse.term) -- |
201 Parse.opt_mixfix -- (\<^keyword>\<open>=\<close> |-- Parse.term) -- |
202 Scan.option |
202 Scan.option |
203 (@{keyword "morphisms"} |-- Parse.!!! (Parse.binding -- Parse.binding)) >> |
203 (\<^keyword>\<open>morphisms\<close> |-- Parse.!!! (Parse.binding -- Parse.binding)) >> |
204 (fn (((((args, t)), mx), A), morphs) => |
204 (fn (((((args, t)), mx), A), morphs) => |
205 Toplevel.theory (domaindef_cmd ((t, args, mx), A, SOME (Typedef.make_morphisms t morphs))))); |
205 Toplevel.theory (domaindef_cmd ((t, args, mx), A, SOME (Typedef.make_morphisms t morphs))))); |
206 |
206 |
207 end |
207 end |