src/Pure/Isar/class_target.ML
changeset 31249 d51d2a22a4f9
parent 31214 b67179528acd
child 31599 97b4d289c646
equal deleted inserted replaced
31248:d1c65a593daf 31249:d51d2a22a4f9
   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