src/Pure/Isar/class.ML
changeset 57069 05ed6e88089e
parent 57067 b3571d1a3e45
child 57070 6a8a01e6dcdf
equal deleted inserted replaced
57068:474403e50e05 57069:05ed6e88089e
   318 
   318 
   319 fun target_extension f class =
   319 fun target_extension f class =
   320   Local_Theory.raw_theory f
   320   Local_Theory.raw_theory f
   321   #> synchronize_class_syntax_target class;
   321   #> synchronize_class_syntax_target class;
   322 
   322 
   323 fun target_const class ((c, mx), dict) (type_params, term_params) thy =
   323 fun class_const class ((b, mx), rhs) (type_params, term_params) thy =
   324   let
   324   let
   325     val morph = morphism thy class;
   325     val morph = morphism thy class;
   326     val class_params = map fst (these_params thy [class]);
   326     val class_params = map fst (these_params thy [class]);
   327     val additional_params =
   327     val additional_params =
   328       subtract (fn (v, Free (w, _)) => v = w | _ => false) class_params term_params;
   328       subtract (fn (v, Free (w, _)) => v = w | _ => false) class_params term_params;
   329     val context_params = map (Morphism.term morph) (type_params @ additional_params);
   329     val context_params = map (Morphism.term morph) (type_params @ additional_params);
   330     val b = Morphism.binding morph c;
   330     val b' = Morphism.binding morph b;
   331     val b_def = Morphism.binding morph (Binding.suffix_name "_dict" b);
   331     val b_def = Morphism.binding morph (Binding.suffix_name "_dict" b');
   332     val c' = Sign.full_name thy b;
   332     val c' = Sign.full_name thy b';
   333     val dict' = Morphism.term morph dict;
   333     val rhs' = Morphism.term morph rhs;
   334     val ty' = map Term.fastype_of context_params ---> Term.fastype_of dict';
   334     val ty' = map Term.fastype_of context_params ---> Term.fastype_of rhs';
   335     val def_eq = Logic.mk_equals (list_comb (Const (c', ty'), context_params), dict')
   335     val def_eq = Logic.mk_equals (list_comb (Const (c', ty'), context_params), rhs')
   336       |> map_types Type.strip_sorts;
   336       |> map_types Type.strip_sorts;
   337   in
   337   in
   338     thy
   338     thy
   339     |> Sign.declare_const_global ((b, Type.strip_sorts ty'), mx)
   339     |> Sign.declare_const_global ((b', Type.strip_sorts ty'), mx)
   340     |> snd
   340     |> snd
   341     |> Thm.add_def_global false false (b_def, def_eq)
   341     |> Thm.add_def_global false false (b_def, def_eq)
   342     |>> apsnd Thm.varifyT_global
   342     |>> apsnd Thm.varifyT_global
   343     |-> (fn (_, def_thm) => Global_Theory.store_thm (b_def, def_thm)
   343     |-> (fn (_, def_thm) => Global_Theory.store_thm (b_def, def_thm)
   344       #> snd
   344       #> snd
   345       #> null context_params ? register_operation class (c', (dict', SOME (Thm.symmetric def_thm))))
   345       #> null context_params ? register_operation class (c', (rhs', SOME (Thm.symmetric def_thm))))
   346     |> Sign.add_const_constraint (c', SOME ty')
   346     |> Sign.add_const_constraint (c', SOME ty')
   347   end;
   347   end;
   348 
   348 
   349 fun target_abbrev class prmode ((c, mx), rhs) thy =
   349 fun class_abbrev class prmode ((b, mx), rhs) thy =
   350   let
   350   let
   351     val morph = morphism thy class;
   351     val morph = morphism thy class;
   352     val unchecks = these_unchecks thy [class];
   352     val unchecks = these_unchecks thy [class];
   353     val b = Morphism.binding morph c;
   353     val b' = Morphism.binding morph b;
   354     val c' = Sign.full_name thy b;
   354     val c' = Sign.full_name thy b';
   355     val rhs' = Pattern.rewrite_term thy unchecks [] rhs;
   355     val rhs' = Pattern.rewrite_term thy unchecks [] rhs;
   356     val ty' = Term.fastype_of rhs';
   356     val ty' = Term.fastype_of rhs';
   357     val rhs'' = Logic.varify_types_global rhs';
       
   358   in
   357   in
   359     thy
   358     thy
   360     |> Sign.add_abbrev (#1 prmode) (b, rhs'')
   359     |> Sign.add_abbrev (#1 prmode) (b', Logic.varify_types_global rhs')
   361     |> snd
   360     |> snd
   362     |> Sign.add_const_constraint (c', SOME ty')
       
   363     |> Sign.notation true prmode [(Const (c', ty'), mx)]
   361     |> Sign.notation true prmode [(Const (c', ty'), mx)]
   364     |> not (#1 prmode = Print_Mode.input) ? register_operation class (c', (rhs', NONE))
   362     |> not (#1 prmode = Print_Mode.input) ? register_operation class (c', (rhs', NONE))
       
   363     |> Sign.add_const_constraint (c', SOME ty')
   365   end;
   364   end;
   366 
   365 
   367 in
   366 in
   368 
   367 
   369 fun const class arg params = target_extension (target_const class arg params) class;
   368 fun const class b_mx_rhs params = target_extension (class_const class b_mx_rhs params) class;
   370 fun abbrev class prmode arg = target_extension (target_abbrev class prmode arg) class;
   369 fun abbrev class prmode b_mx_rhs = target_extension (class_abbrev class prmode b_mx_rhs) class;
   371 
   370 
   372 end;
   371 end;
   373 
   372 
   374 
   373 
   375 (* subclasses *)
   374 (* subclasses *)