src/Pure/Isar/code.ML
changeset 36202 43ea1f28fc7c
parent 36122 45f8898fe4cf
child 36209 566be5d48090
equal deleted inserted replaced
36199:4d220994f30b 36202:43ea1f28fc7c
   531     val (full_lhs, rhs) = (Logic.dest_equals o Thm.plain_prop_of) thm
   531     val (full_lhs, rhs) = (Logic.dest_equals o Thm.plain_prop_of) thm
   532       handle TERM _ => bad "Not an equation"
   532       handle TERM _ => bad "Not an equation"
   533            | THM _ => bad "Not a proper equation";
   533            | THM _ => bad "Not a proper equation";
   534     val (rep, lhs) = dest_comb full_lhs
   534     val (rep, lhs) = dest_comb full_lhs
   535       handle TERM _ => bad "Not an abstract equation";
   535       handle TERM _ => bad "Not an abstract equation";
   536     val tyco = (fst o dest_Type o domain_type o snd o dest_Const) rep
   536     val (rep_const, ty) = dest_Const rep;
       
   537     val (tyco, sorts) = ((apsnd o map) (snd o dest_TVar) o dest_Type o domain_type) ty
   537       handle TERM _ => bad "Not an abstract equation";
   538       handle TERM _ => bad "Not an abstract equation";
   538     val _ = case some_tyco of SOME tyco' => if tyco = tyco' then ()
   539     val _ = case some_tyco of SOME tyco' => if tyco = tyco' then ()
   539           else bad ("Abstract type mismatch:" ^ quote tyco ^ " vs. " ^ quote tyco')
   540           else bad ("Abstract type mismatch:" ^ quote tyco ^ " vs. " ^ quote tyco')
   540       | NONE => ();
   541       | NONE => ();
   541     val (_, (_, (rep', _))) = get_abstype_spec thy tyco;
   542     val (vs', (_, (rep', _))) = get_abstype_spec thy tyco;
   542     val rep_const = (fst o dest_Const) rep;
       
   543     val _ = if rep_const = rep' then ()
   543     val _ = if rep_const = rep' then ()
   544       else bad ("Projection mismatch: " ^ quote rep_const ^ " vs. " ^ quote rep');
   544       else bad ("Projection mismatch: " ^ quote rep_const ^ " vs. " ^ quote rep');
   545     val _ = check_eqn thy { allow_nonlinear = false,
   545     val _ = check_eqn thy { allow_nonlinear = false,
   546       allow_consts = false, allow_pats = false } thm (lhs, rhs);
   546       allow_consts = false, allow_pats = false } thm (lhs, rhs);
       
   547     val _ = if forall (Sign.subsort thy) (sorts ~~ map snd  vs') then ()
       
   548       else error ("Sort constraints on type arguments are weaker than in abstype certificate.")
   547   in (thm, tyco) end;
   549   in (thm, tyco) end;
   548 
   550 
   549 fun assert_eqn thy = error_thm (gen_assert_eqn thy true);
   551 fun assert_eqn thy = error_thm (gen_assert_eqn thy true);
   550 
   552 
   551 fun meta_rewrite thy = Local_Defs.meta_rewrite_rule (ProofContext.init thy);
   553 fun meta_rewrite thy = Local_Defs.meta_rewrite_rule (ProofContext.init thy);
   807       (fst (typscheme_projection thy t), add_rhss_of_eqn thy t [])
   809       (fst (typscheme_projection thy t), add_rhss_of_eqn thy t [])
   808   | typargs_deps_of_cert thy (Abstract (abs_thm, tyco)) =
   810   | typargs_deps_of_cert thy (Abstract (abs_thm, tyco)) =
   809       let
   811       let
   810         val vs = fst (typscheme_abs thy abs_thm);
   812         val vs = fst (typscheme_abs thy abs_thm);
   811         val (_, concrete_thm) = concretify_abs thy tyco abs_thm;
   813         val (_, concrete_thm) = concretify_abs thy tyco abs_thm;
   812       in (vs, add_rhss_of_eqn thy (Thm.prop_of abs_thm) []) end;
   814       in (vs, add_rhss_of_eqn thy (map_types Logic.unvarifyT_global (Thm.prop_of concrete_thm)) []) end;
   813 
   815 
   814 fun equations_of_cert thy (cert as Equations (cert_thm, propers)) =
   816 fun equations_of_cert thy (cert as Equations (cert_thm, propers)) =
   815       let
   817       let
   816         val tyscm = typscheme_of_cert thy cert;
   818         val tyscm = typscheme_of_cert thy cert;
   817         val thms = if null propers then [] else
   819         val thms = if null propers then [] else