src/Pure/Isar/specification.ML
changeset 21435 883337ea2f3b
parent 21370 d9dd7b4e5e69
child 21450 f16c9e6401d1
equal deleted inserted replaced
21434:944f80576be0 21435:883337ea2f3b
   100     val spec_frees = member (op =) (fold (fold Term.add_frees o snd) specs []);
   100     val spec_frees = member (op =) (fold (fold Term.add_frees o snd) specs []);
   101 
   101 
   102     val ((consts, axioms), lthy') = lthy
   102     val ((consts, axioms), lthy') = lthy
   103       |> LocalTheory.consts spec_frees vars
   103       |> LocalTheory.consts spec_frees vars
   104       ||> fold (fold Variable.auto_fixes o snd) specs   (* FIXME !? *)
   104       ||> fold (fold Variable.auto_fixes o snd) specs   (* FIXME !? *)
   105       ||>> LocalTheory.axioms specs;
   105       ||>> LocalTheory.axioms Thm.axiomK specs;
   106 
   106 
   107     (* FIXME generic target!? *)
   107     (* FIXME generic target!? *)
   108     val hs = map (Term.head_of o #2 o Logic.dest_equals o Thm.prop_of o #2) consts;
   108     val hs = map (Term.head_of o #2 o Logic.dest_equals o Thm.prop_of o #2) consts;
   109     val lthy'' = lthy' |> LocalTheory.theory (Theory.add_finals_i false hs);
   109     val lthy'' = lthy' |> LocalTheory.theory (Theory.add_finals_i false hs);
   110 
   110 
   128         val mx = (case vars of [] => NoSyn | [((x', _), mx)] =>
   128         val mx = (case vars of [] => NoSyn | [((x', _), mx)] =>
   129           if x = x' then mx
   129           if x = x' then mx
   130           else error ("Head of definition " ^ quote x ^ " differs from declaration " ^ quote x'));
   130           else error ("Head of definition " ^ quote x ^ " differs from declaration " ^ quote x'));
   131         val ((lhs, (_, th)), lthy2) = lthy1
   131         val ((lhs, (_, th)), lthy2) = lthy1
   132 (*          |> LocalTheory.def ((x, mx), ((name ^ "_raw", []), rhs));  FIXME *)
   132 (*          |> LocalTheory.def ((x, mx), ((name ^ "_raw", []), rhs));  FIXME *)
   133           |> LocalTheory.def ((x, mx), ((name, []), rhs));
   133           |> LocalTheory.def Thm.definitionK ((x, mx), ((name, []), rhs));
   134         val ((b, [th']), lthy3) = lthy2
   134         val ((b, [th']), lthy3) = lthy2
   135           |> LocalTheory.note ((name, atts), [prove lthy2 th]);
   135           |> LocalTheory.note Thm.definitionK ((name, atts), [prove lthy2 th]);
   136       in (((x, T), (lhs, (b, th'))), LocalTheory.restore lthy3) end;
   136       in (((x, T), (lhs, (b, th'))), LocalTheory.restore lthy3) end;
   137 
   137 
   138     val ((cs, defs), lthy') = lthy |> fold_map define args |>> split_list;
   138     val ((cs, defs), lthy') = lthy |> fold_map define args |>> split_list;
   139     val def_frees = member (op =) (fold (Term.add_frees o fst) defs []);
   139     val def_frees = member (op =) (fold (Term.add_frees o fst) defs []);
   140     val _ = print_consts lthy' def_frees cs;
   140     val _ = print_consts lthy' def_frees cs;
   183 
   183 
   184 (* fact statements *)
   184 (* fact statements *)
   185 
   185 
   186 fun gen_theorems prep_thms prep_att kind raw_facts lthy =
   186 fun gen_theorems prep_thms prep_att kind raw_facts lthy =
   187   let
   187   let
   188     val k = if kind = "" then [] else [Attrib.kind kind];
       
   189     val attrib = prep_att (ProofContext.theory_of lthy);
   188     val attrib = prep_att (ProofContext.theory_of lthy);
   190     val facts = raw_facts |> map (fn ((name, atts), bs) =>
   189     val facts = raw_facts |> map (fn ((name, atts), bs) =>
   191       ((name, map attrib atts),
   190       ((name, map attrib atts),
   192         bs |> map (fn (b, more_atts) => (prep_thms lthy b, map attrib more_atts @ k))));
   191         bs |> map (fn (b, more_atts) => (prep_thms lthy b, map attrib more_atts))));
   193     val (res, lthy') = lthy |> LocalTheory.notes facts;
   192     val (res, lthy') = lthy |> LocalTheory.notes kind facts;
   194     val _ = present_results' lthy' kind res;
   193     val _ = present_results' lthy' kind res;
   195   in (res, lthy') end;
   194   in (res, lthy') end;
   196 
   195 
   197 val theorems = gen_theorems ProofContext.get_thms Attrib.intern_src;
   196 val theorems = gen_theorems ProofContext.get_thms Attrib.intern_src;
   198 val theorems_i = gen_theorems (K I) (K I);
   197 val theorems_i = gen_theorems (K I) (K I);
   244         val stmt = [(("", atts), [(thesis, [])])];
   243         val stmt = [(("", atts), [(thesis, [])])];
   245 
   244 
   246         val (facts, goal_ctxt) = elems_ctxt
   245         val (facts, goal_ctxt) = elems_ctxt
   247           |> (snd o ProofContext.add_fixes_i [(AutoBind.thesisN, NONE, NoSyn)])
   246           |> (snd o ProofContext.add_fixes_i [(AutoBind.thesisN, NONE, NoSyn)])
   248           |> fold_map assume_case (obtains ~~ propp)
   247           |> fold_map assume_case (obtains ~~ propp)
   249           |-> (fn ths =>
   248           |-> (fn ths => ProofContext.note_thmss_i Thm.assumptionK
   250             ProofContext.note_thmss_i [((Obtain.thatN, []), [(ths, [])])] #> #2 #> pair ths);
   249                 [((Obtain.thatN, []), [(ths, [])])] #> #2 #> pair ths);
   251       in ((stmt, facts), goal_ctxt) end);
   250       in ((stmt, facts), goal_ctxt) end);
   252 
   251 
   253 fun gen_theorem prep_att prep_stmt
   252 fun gen_theorem prep_att prep_stmt
   254     kind before_qed after_qed (name, raw_atts) raw_elems raw_concl lthy0 =
   253     kind before_qed after_qed (name, raw_atts) raw_elems raw_concl lthy0 =
   255   let
   254   let
   256     val _ = LocalTheory.assert lthy0;
   255     val _ = LocalTheory.assert lthy0;
   257     val thy = ProofContext.theory_of lthy0;
   256     val thy = ProofContext.theory_of lthy0;
   258     val attrib = prep_att thy;
       
   259 
   257 
   260     val (loc, ctxt, lthy) =
   258     val (loc, ctxt, lthy) =
   261       (case (TheoryTarget.peek lthy0, exists (fn Locale.Expr _ => true | _ => false) raw_elems) of
   259       (case (TheoryTarget.peek lthy0, exists (fn Locale.Expr _ => true | _ => false) raw_elems) of
   262         (SOME loc, true) => (* workaround non-modularity of in/includes *)  (* FIXME *)
   260         (SOME loc, true) => (* workaround non-modularity of in/includes *)  (* FIXME *)
   263           (SOME loc, ProofContext.init thy, LocalTheory.restore lthy0)
   261           (SOME loc, ProofContext.init thy, LocalTheory.restore lthy0)
   264       | _ => (NONE, lthy0, lthy0));
   262       | _ => (NONE, lthy0, lthy0));
   265 
   263 
       
   264     val attrib = prep_att thy;
       
   265     val atts = map attrib raw_atts;
       
   266 
   266     val elems = raw_elems |> (map o Locale.map_elem)
   267     val elems = raw_elems |> (map o Locale.map_elem)
   267       (Element.map_ctxt {name = I, var = I, typ = I, term = I, fact = I, attrib = attrib});
   268       (Element.map_ctxt {name = I, var = I, typ = I, term = I, fact = I, attrib = attrib});
   268     val ((stmt, facts), goal_ctxt) = prep_statement attrib (prep_stmt loc) elems raw_concl ctxt;
   269     val ((stmt, facts), goal_ctxt) = prep_statement attrib (prep_stmt loc) elems raw_concl ctxt;
   269 
   270 
   270     val k = if kind = "" then [] else [Attrib.kind kind];
       
   271     val names = map (fst o fst) stmt;
       
   272     val attss = map (fn ((_, atts), _) => atts @ k) stmt;
       
   273     val atts = map attrib raw_atts @ k;
       
   274 
       
   275     fun after_qed' results goal_ctxt' =
   271     fun after_qed' results goal_ctxt' =
   276       let val results' = burrow (ProofContext.export_standard goal_ctxt' lthy) results in
   272       let val results' = burrow (ProofContext.export_standard goal_ctxt' lthy) results in
   277         lthy
   273         lthy
   278         |> LocalTheory.notes ((names ~~ attss) ~~ map (fn ths => [(ths, [])]) results')
   274         |> LocalTheory.notes kind (map2 (fn (a, _) => fn ths => (a, [(ths, [])])) stmt results')
   279         |> (fn (res, lthy') =>
   275         |> (fn (res, lthy') =>
   280           (present_results lthy' ((kind, name), res);
   276           (present_results lthy' ((kind, name), res);
   281             if name = "" andalso null raw_atts then lthy'
   277             if name = "" andalso null atts then lthy'
   282             else #2 (LocalTheory.notes [((name, atts), [(maps #2 res, [])])] lthy')))
   278             else #2 (LocalTheory.notes kind [((name, atts), [(maps #2 res, [])])] lthy')))
   283         |> after_qed results'
   279         |> after_qed results'
   284       end;
   280       end;
   285   in
   281   in
   286     goal_ctxt
   282     goal_ctxt
   287     |> Proof.theorem_i kind before_qed after_qed' (map snd stmt)
   283     |> Proof.theorem_i before_qed after_qed' (map snd stmt)
   288     |> Proof.refine_insert facts
   284     |> Proof.refine_insert facts
   289   end;
   285   end;
   290 
   286 
   291 in
   287 in
   292 
   288