src/Pure/Isar/specification.ML
changeset 30223 24d975352879
parent 29606 fedb8be05f24
child 30344 10a67c5ddddb
equal deleted inserted replaced
30222:4102bbf2af21 30223:24d975352879
   138 (* axiomatization -- within global theory *)
   138 (* axiomatization -- within global theory *)
   139 
   139 
   140 fun gen_axioms do_print prep raw_vars raw_specs thy =
   140 fun gen_axioms do_print prep raw_vars raw_specs thy =
   141   let
   141   let
   142     val ((vars, specs), _) = prep raw_vars [raw_specs] (ProofContext.init thy);
   142     val ((vars, specs), _) = prep raw_vars [raw_specs] (ProofContext.init thy);
   143     val xs = map (fn ((b, T), _) => (Binding.base_name b, T)) vars;
   143     val xs = map (fn ((b, T), _) => (Binding.name_of b, T)) vars;
   144 
   144 
   145     (*consts*)
   145     (*consts*)
   146     val (consts, consts_thy) = thy |> fold_map (Theory.specify_const []) vars;
   146     val (consts, consts_thy) = thy |> fold_map (Theory.specify_const []) vars;
   147     val subst = Term.subst_atomic (map Free xs ~~ consts);
   147     val subst = Term.subst_atomic (map Free xs ~~ consts);
   148 
   148 
   149     (*axioms*)
   149     (*axioms*)
   150     val (axioms, axioms_thy) = consts_thy |> fold_map (fn ((b, atts), props) =>
   150     val (axioms, axioms_thy) = consts_thy |> fold_map (fn ((b, atts), props) =>
   151         fold_map Thm.add_axiom
   151         fold_map Thm.add_axiom  (* FIXME proper use of binding!? *)
   152           ((map o apfst) Binding.name (PureThy.name_multi (Binding.base_name b) (map subst props)))
   152           ((map o apfst) Binding.name (PureThy.name_multi (Binding.name_of b) (map subst props)))
   153         #>> (fn ths => ((b, atts), [(map Drule.standard' ths, [])]))) specs;
   153         #>> (fn ths => ((b, atts), [(map Drule.standard' ths, [])]))) specs;
   154     val (facts, thy') = axioms_thy |> PureThy.note_thmss Thm.axiomK
   154     val (facts, thy') = axioms_thy |> PureThy.note_thmss Thm.axiomK
   155       (Attrib.map_facts (Attrib.attribute_i axioms_thy) axioms);
   155       (Attrib.map_facts (Attrib.attribute_i axioms_thy) axioms);
   156     val _ =
   156     val _ =
   157       if not do_print then ()
   157       if not do_print then ()
   167 fun gen_def do_print prep (raw_var, (raw_a, raw_prop)) lthy =
   167 fun gen_def do_print prep (raw_var, (raw_a, raw_prop)) lthy =
   168   let
   168   let
   169     val (vars, [((raw_name, atts), [prop])]) =
   169     val (vars, [((raw_name, atts), [prop])]) =
   170       fst (prep (the_list raw_var) [(raw_a, [raw_prop])] lthy);
   170       fst (prep (the_list raw_var) [(raw_a, [raw_prop])] lthy);
   171     val (((x, T), rhs), prove) = LocalDefs.derived_def lthy true prop;
   171     val (((x, T), rhs), prove) = LocalDefs.derived_def lthy true prop;
   172     val name = Binding.map_base (Thm.def_name_optional x) raw_name;
   172     val name = Binding.map_name (Thm.def_name_optional x) raw_name;
   173     val var =
   173     val var =
   174       (case vars of
   174       (case vars of
   175         [] => (Binding.name x, NoSyn)
   175         [] => (Binding.name x, NoSyn)
   176       | [((b, _), mx)] =>
   176       | [((b, _), mx)] =>
   177           let
   177           let
   178             val y = Binding.base_name b;
   178             val y = Binding.name_of b;
   179             val _ = x = y orelse
   179             val _ = x = y orelse
   180               error ("Head of definition " ^ quote x ^ " differs from declaration " ^ quote y ^
   180               error ("Head of definition " ^ quote x ^ " differs from declaration " ^ quote y ^
   181                 Position.str_of (Binding.pos_of b));
   181                 Position.str_of (Binding.pos_of b));
   182           in (b, mx) end);
   182           in (b, mx) end);
   183     val ((lhs, (_, th)), lthy2) = lthy |> LocalTheory.define Thm.definitionK
   183     val ((lhs, (_, th)), lthy2) = lthy |> LocalTheory.define Thm.definitionK
   184         (var, ((Binding.map_base (suffix "_raw") name, []), rhs));
   184         (var, ((Binding.map_name (suffix "_raw") name, []), rhs));
   185     val ((def_name, [th']), lthy3) = lthy2 |> LocalTheory.note Thm.definitionK
   185     val ((def_name, [th']), lthy3) = lthy2 |> LocalTheory.note Thm.definitionK
   186         ((name, Code.add_default_eqn_attrib :: atts), [prove lthy2 th]);
   186         ((name, Code.add_default_eqn_attrib :: atts), [prove lthy2 th]);
   187 
   187 
   188     val lhs' = Morphism.term (LocalTheory.target_morphism lthy3) lhs;
   188     val lhs' = Morphism.term (LocalTheory.target_morphism lthy3) lhs;
   189     val _ =
   189     val _ =
   206     val var =
   206     val var =
   207       (case vars of
   207       (case vars of
   208         [] => (Binding.name x, NoSyn)
   208         [] => (Binding.name x, NoSyn)
   209       | [((b, _), mx)] =>
   209       | [((b, _), mx)] =>
   210           let
   210           let
   211             val y = Binding.base_name b;
   211             val y = Binding.name_of b;
   212             val _ = x = y orelse
   212             val _ = x = y orelse
   213               error ("Head of abbreviation " ^ quote x ^ " differs from declaration " ^ quote y ^
   213               error ("Head of abbreviation " ^ quote x ^ " differs from declaration " ^ quote y ^
   214                 Position.str_of (Binding.pos_of b));
   214                 Position.str_of (Binding.pos_of b));
   215           in (b, mx) end);
   215           in (b, mx) end);
   216     val lthy' = lthy
   216     val lthy' = lthy
   267         val goal_ctxt = fold (fold (Variable.auto_fixes o fst)) propp elems_ctxt;
   267         val goal_ctxt = fold (fold (Variable.auto_fixes o fst)) propp elems_ctxt;
   268       in ((prems, stmt, []), goal_ctxt) end
   268       in ((prems, stmt, []), goal_ctxt) end
   269   | Element.Obtains obtains =>
   269   | Element.Obtains obtains =>
   270       let
   270       let
   271         val case_names = obtains |> map_index (fn (i, (b, _)) =>
   271         val case_names = obtains |> map_index (fn (i, (b, _)) =>
   272           let val name = Binding.base_name b
   272           if Binding.is_empty b then string_of_int (i + 1) else Binding.name_of b);
   273           in if name = "" then string_of_int (i + 1) else name end);
       
   274         val constraints = obtains |> map (fn (_, (vars, _)) =>
   273         val constraints = obtains |> map (fn (_, (vars, _)) =>
   275           Element.Constrains
   274           Element.Constrains
   276             (vars |> map_filter (fn (x, SOME T) => SOME (Binding.base_name x, T) | _ => NONE)));
   275             (vars |> map_filter (fn (x, SOME T) => SOME (Binding.name_of x, T) | _ => NONE)));
   277 
   276 
   278         val raw_propp = obtains |> map (fn (_, (_, props)) => map (rpair []) props);
   277         val raw_propp = obtains |> map (fn (_, (_, props)) => map (rpair []) props);
   279         val (propp, elems_ctxt) = prep_stmt (elems @ constraints) raw_propp ctxt;
   278         val (propp, elems_ctxt) = prep_stmt (elems @ constraints) raw_propp ctxt;
   280 
   279 
   281         val thesis = ObjectLogic.fixed_judgment (ProofContext.theory_of ctxt) AutoBind.thesisN;
   280         val thesis = ObjectLogic.fixed_judgment (ProofContext.theory_of ctxt) AutoBind.thesisN;
   282 
   281 
   283         fun assume_case ((name, (vars, _)), asms) ctxt' =
   282         fun assume_case ((name, (vars, _)), asms) ctxt' =
   284           let
   283           let
   285             val bs = map fst vars;
   284             val bs = map fst vars;
   286             val xs = map Binding.base_name bs;
   285             val xs = map Binding.name_of bs;
   287             val props = map fst asms;
   286             val props = map fst asms;
   288             val (Ts, _) = ctxt'
   287             val (Ts, _) = ctxt'
   289               |> fold Variable.declare_term props
   288               |> fold Variable.declare_term props
   290               |> fold_map ProofContext.inferred_param xs;
   289               |> fold_map ProofContext.inferred_param xs;
   291             val asm = Term.list_all_free (xs ~~ Ts, Logic.list_implies (props, thesis));
   290             val asm = Term.list_all_free (xs ~~ Ts, Logic.list_implies (props, thesis));