src/HOL/Tools/Function/partial_function.ML
changeset 43080 73a1d6a7ef1d
parent 42949 618adb3584e5
child 43083 df41a5762c3d
equal deleted inserted replaced
43079:4022892a2f28 43080:73a1d6a7ef1d
     5 *)
     5 *)
     6 
     6 
     7 signature PARTIAL_FUNCTION =
     7 signature PARTIAL_FUNCTION =
     8 sig
     8 sig
     9   val setup: theory -> theory
     9   val setup: theory -> theory
    10   val init: string -> term -> term -> thm -> declaration
    10   val init: string -> term -> term -> thm -> thm option -> declaration
    11 
    11 
    12   val add_partial_function: string -> (binding * typ option * mixfix) list ->
    12   val add_partial_function: string -> (binding * typ option * mixfix) list ->
    13     Attrib.binding * term -> local_theory -> local_theory
    13     Attrib.binding * term -> local_theory -> local_theory
    14 
    14 
    15   val add_partial_function_cmd: string -> (binding * string option * mixfix) list ->
    15   val add_partial_function_cmd: string -> (binding * string option * mixfix) list ->
    20 structure Partial_Function: PARTIAL_FUNCTION =
    20 structure Partial_Function: PARTIAL_FUNCTION =
    21 struct
    21 struct
    22 
    22 
    23 (*** Context Data ***)
    23 (*** Context Data ***)
    24 
    24 
       
    25 datatype setup_data = Setup_Data of 
       
    26  {fixp: term,
       
    27   mono: term,
       
    28   fixp_eq: thm,
       
    29   fixp_induct: thm option};
       
    30 
    25 structure Modes = Generic_Data
    31 structure Modes = Generic_Data
    26 (
    32 (
    27   type T = ((term * term) * thm) Symtab.table;
    33   type T = setup_data Symtab.table;
    28   val empty = Symtab.empty;
    34   val empty = Symtab.empty;
    29   val extend = I;
    35   val extend = I;
    30   fun merge data = Symtab.merge (K true) data;
    36   fun merge data = Symtab.merge (K true) data;
    31 )
    37 )
    32 
    38 
    33 fun init mode fixp mono fixp_eq phi =
    39 fun init mode fixp mono fixp_eq fixp_induct phi =
    34   let
    40   let
    35     val term = Morphism.term phi;
    41     val term = Morphism.term phi;
    36     val data' = ((term fixp, term mono), Morphism.thm phi fixp_eq);
    42     val thm = Morphism.thm phi;
       
    43     val data' = Setup_Data 
       
    44       {fixp=term fixp, mono=term mono, fixp_eq=thm fixp_eq,
       
    45        fixp_induct=Option.map thm fixp_induct};
    37   in
    46   in
    38     Modes.map (Symtab.update (mode, data'))
    47     Modes.map (Symtab.update (mode, data'))
    39   end
    48   end
    40 
    49 
    41 val known_modes = Symtab.keys o Modes.get o Context.Proof;
    50 val known_modes = Symtab.keys o Modes.get o Context.Proof;
   154 
   163 
   155 (*** partial_function definition ***)
   164 (*** partial_function definition ***)
   156 
   165 
   157 fun gen_add_partial_function prep mode fixes_raw eqn_raw lthy =
   166 fun gen_add_partial_function prep mode fixes_raw eqn_raw lthy =
   158   let
   167   let
   159     val ((fixp, mono), fixp_eq) = the (lookup_mode lthy mode)
   168     val setup_data = the (lookup_mode lthy mode)
   160       handle Option.Option => error (cat_lines ["Unknown mode " ^ quote mode ^ ".",
   169       handle Option.Option => error (cat_lines ["Unknown mode " ^ quote mode ^ ".",
   161         "Known modes are " ^ commas_quote (known_modes lthy) ^ "."]);
   170         "Known modes are " ^ commas_quote (known_modes lthy) ^ "."]);
       
   171     val Setup_Data {fixp, mono, fixp_eq, fixp_induct} = setup_data;
   162 
   172 
   163     val ((fixes, [(eq_abinding, eqn)]), _) = prep fixes_raw [eqn_raw] lthy;
   173     val ((fixes, [(eq_abinding, eqn)]), _) = prep fixes_raw [eqn_raw] lthy;
   164     val ((_, plain_eqn), _) = Variable.focus eqn lthy;
   174     val ((_, plain_eqn), _) = Variable.focus eqn lthy;
   165 
   175 
   166     val ((f_binding, fT), mixfix) = the_single fixes;
   176     val ((f_binding, fT), mixfix) = the_single fixes;