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 *) |