src/HOL/HOLCF/Tools/domaindef.ML
changeset 69597 ff784d5a5bfb
parent 63180 ddfd021884b4
child 74305 28a582aa25dd
equal deleted inserted replaced
69596:c8a2755bf220 69597:ff784d5a5bfb
    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