439 (* syntax *) |
439 (* syntax *) |
440 |
440 |
441 fun synchronize_inst_syntax ctxt = |
441 fun synchronize_inst_syntax ctxt = |
442 let |
442 let |
443 val Instantiation { arities = (_, _, sort), params = params } = Instantiation.get ctxt; |
443 val Instantiation { arities = (_, _, sort), params = params } = Instantiation.get ctxt; |
444 val inst_tyco_of = AxClass.inst_tyco_of (Sign.consts_of (ProofContext.theory_of ctxt)); |
444 |
445 fun subst (c, ty) = case inst_tyco_of (c, ty) |
445 val lookup_inst_param = AxClass.lookup_inst_param (Sign.consts_of (ProofContext.theory_of ctxt)) params; |
446 of SOME tyco => (case AList.lookup (op =) params (c, tyco) |
446 fun subst (c, ty) = case lookup_inst_param (c, ty) |
447 of SOME (v_ty as (_, ty)) => SOME (ty, Free v_ty) |
447 of SOME (v_ty as (_, ty)) => SOME (ty, Free v_ty) |
448 | NONE => NONE) |
448 | NONE => NONE; |
449 | NONE => NONE; |
|
450 val unchecks = |
449 val unchecks = |
451 map (fn ((c, _), v_ty as (_, ty)) => (Free v_ty, Const (c, ty))) params; |
450 map (fn ((c, _), v_ty as (_, ty)) => (Free v_ty, Const (c, ty))) params; |
452 in |
451 in |
453 ctxt |
452 ctxt |
454 |> Overloading.map_improvable_syntax |
453 |> Overloading.map_improvable_syntax |
492 in if Vartab.is_empty tvartab then NONE else SOME ((map o map_types) inst ts) end; |
491 in if Vartab.is_empty tvartab then NONE else SOME ((map o map_types) inst ts) end; |
493 |
492 |
494 fun init_instantiation (tycos, vs, sort) thy = |
493 fun init_instantiation (tycos, vs, sort) thy = |
495 let |
494 let |
496 val _ = if null tycos then error "At least one arity must be given" else (); |
495 val _ = if null tycos then error "At least one arity must be given" else (); |
497 val params = these_params thy (filter (can (AxClass.get_info thy)) sort); |
496 val class_params = these_params thy (filter (can (AxClass.get_info thy)) sort); |
498 fun get_param tyco (param, (_, (c, ty))) = |
497 fun get_param tyco (param, (_, (c, ty))) = |
499 if can (AxClass.param_of_inst thy) (c, tyco) |
498 if can (AxClass.param_of_inst thy) (c, tyco) |
500 then NONE else SOME ((c, tyco), |
499 then NONE else SOME ((c, tyco), |
501 (param ^ "_" ^ type_name tyco, map_atyps (K (Type (tyco, map TFree vs))) ty)); |
500 (param ^ "_" ^ type_name tyco, map_atyps (K (Type (tyco, map TFree vs))) ty)); |
502 val inst_params = map_product get_param tycos params |> map_filter I; |
501 val params = map_product get_param tycos class_params |> map_filter I; |
503 val primary_constraints = map (apsnd |
502 val primary_constraints = map (apsnd |
504 (map_atyps (K (TVar ((Name.aT, 0), [])))) o snd o snd) params; |
503 (map_atyps (K (TVar ((Name.aT, 0), [])))) o snd o snd) class_params; |
505 val pp = Syntax.pp_global thy; |
504 val pp = Syntax.pp_global thy; |
506 val algebra = Sign.classes_of thy |
505 val algebra = Sign.classes_of thy |
507 |> fold (fn tyco => Sorts.add_arities pp |
506 |> fold (fn tyco => Sorts.add_arities pp |
508 (tyco, map (fn class => (class, map snd vs)) sort)) tycos; |
507 (tyco, map (fn class => (class, map snd vs)) sort)) tycos; |
509 val consts = Sign.consts_of thy; |
508 val consts = Sign.consts_of thy; |
510 val improve_constraints = AList.lookup (op =) |
509 val improve_constraints = AList.lookup (op =) |
511 (map (fn (_, (class, (c, _))) => (c, [[class]])) params); |
510 (map (fn (_, (class, (c, _))) => (c, [[class]])) class_params); |
512 fun resort_check ts ctxt = case resort_terms pp algebra consts improve_constraints ts |
511 fun resort_check ts ctxt = case resort_terms pp algebra consts improve_constraints ts |
513 of NONE => NONE |
512 of NONE => NONE |
514 | SOME ts' => SOME (ts', ctxt); |
513 | SOME ts' => SOME (ts', ctxt); |
515 val inst_tyco_of = AxClass.inst_tyco_of consts; |
514 val lookup_inst_param = AxClass.lookup_inst_param consts params; |
516 val typ_instance = Type.typ_instance (Sign.tsig_of thy); |
515 val typ_instance = Type.typ_instance (Sign.tsig_of thy); |
517 fun improve (c, ty) = case inst_tyco_of (c, ty) |
516 fun improve (c, ty) = case lookup_inst_param (c, ty) |
518 of SOME tyco => (case AList.lookup (op =) inst_params (c, tyco) |
517 of SOME (_, ty') => if typ_instance (ty', ty) then SOME (ty, ty') else NONE |
519 of SOME (_, ty') => if typ_instance (ty', ty) |
|
520 then SOME (ty, ty') else NONE |
|
521 | NONE => NONE) |
|
522 | NONE => NONE; |
518 | NONE => NONE; |
523 in |
519 in |
524 thy |
520 thy |
525 |> ProofContext.init |
521 |> ProofContext.init |
526 |> Instantiation.put (mk_instantiation ((tycos, vs, sort), inst_params)) |
522 |> Instantiation.put (mk_instantiation ((tycos, vs, sort), params)) |
527 |> fold (Variable.declare_typ o TFree) vs |
523 |> fold (Variable.declare_typ o TFree) vs |
528 |> fold (Variable.declare_names o Free o snd) inst_params |
524 |> fold (Variable.declare_names o Free o snd) params |
529 |> (Overloading.map_improvable_syntax o apfst) |
525 |> (Overloading.map_improvable_syntax o apfst) |
530 (K ((primary_constraints, []), (((improve, K NONE), false), []))) |
526 (K ((primary_constraints, []), (((improve, K NONE), false), []))) |
531 |> Overloading.add_improvable_syntax |
527 |> Overloading.add_improvable_syntax |
532 |> Context.proof_map (Syntax.add_term_check 0 "resorting" resort_check) |
528 |> Context.proof_map (Syntax.add_term_check 0 "resorting" resort_check) |
533 |> synchronize_inst_syntax |
529 |> synchronize_inst_syntax |