src/Pure/Isar/specification.ML
changeset 63064 2f18172214c8
parent 63063 c9605a284fba
child 63065 3cb7b06d0a9f
equal deleted inserted replaced
63063:c9605a284fba 63064:2f18172214c8
     9 sig
     9 sig
    10   val read_props: string list -> (binding * string option * mixfix) list -> Proof.context ->
    10   val read_props: string list -> (binding * string option * mixfix) list -> Proof.context ->
    11     term list * Proof.context
    11     term list * Proof.context
    12   val read_prop: string -> (binding * string option * mixfix) list -> Proof.context ->
    12   val read_prop: string -> (binding * string option * mixfix) list -> Proof.context ->
    13     term * Proof.context
    13     term * Proof.context
    14   val check_free_spec:
    14   val check_spec: (binding * typ option * mixfix) list ->
    15     (binding * typ option * mixfix) list -> (Attrib.binding * term) list -> Proof.context ->
    15     term list -> Attrib.binding * term -> Proof.context ->
    16     ((((binding * typ) * mixfix) list * (Attrib.binding * term) list) * (string -> Position.T))
    16     ((((binding * typ) * mixfix) list * (Attrib.binding * term)) * (string -> Position.T))
    17       * Proof.context
    17       * Proof.context
    18   val read_free_spec:
    18   val read_spec: (binding * string option * mixfix) list ->
    19     (binding * string option * mixfix) list -> (Attrib.binding * string) list -> Proof.context ->
    19     string list -> Attrib.binding * string -> Proof.context ->
    20     ((((binding * typ) * mixfix) list * (Attrib.binding * term) list) * (string -> Position.T))
    20     ((((binding * typ) * mixfix) list * (Attrib.binding * term)) * (string -> Position.T))
    21       * Proof.context
    21       * Proof.context
    22   val check_spec:
    22   type multi_specs = ((Attrib.binding * term) * term list) list
    23     (binding * typ option * mixfix) list -> (Attrib.binding * term) list -> Proof.context ->
    23   type multi_specs_cmd = ((Attrib.binding * string) * string list) list
       
    24   val check_multi_specs: (binding * typ option * mixfix) list -> multi_specs -> Proof.context ->
    24     (((binding * typ) * mixfix) list * (Attrib.binding * term) list) * Proof.context
    25     (((binding * typ) * mixfix) list * (Attrib.binding * term) list) * Proof.context
    25   val read_spec:
    26   val read_multi_specs: (binding * string option * mixfix) list -> multi_specs_cmd -> Proof.context ->
    26     (binding * string option * mixfix) list -> (Attrib.binding * string) list -> Proof.context ->
       
    27     (((binding * typ) * mixfix) list * (Attrib.binding * term) list) * Proof.context
    27     (((binding * typ) * mixfix) list * (Attrib.binding * term) list) * Proof.context
    28   val check_specification: (binding * typ option * mixfix) list ->
    28   val check_specification: (binding * typ option * mixfix) list -> term list ->
    29     (Attrib.binding * term list) list -> Proof.context ->
    29     (Attrib.binding * term list) list -> Proof.context ->
    30     (((binding * typ) * mixfix) list * (Attrib.binding * term list) list) * Proof.context
    30     (((binding * typ) * mixfix) list * (Attrib.binding * term list) list) * Proof.context
    31   val read_specification: (binding * string option * mixfix) list ->
    31   val read_specification: (binding * string option * mixfix) list -> string list ->
    32     (Attrib.binding * string list) list -> Proof.context ->
    32     (Attrib.binding * string list) list -> Proof.context ->
    33     (((binding * typ) * mixfix) list * (Attrib.binding * term list) list) * Proof.context
    33     (((binding * typ) * mixfix) list * (Attrib.binding * term list) list) * Proof.context
    34   val axiomatization: (binding * typ option * mixfix) list ->
    34   val axiomatization: (binding * typ option * mixfix) list -> term list ->
    35     (Attrib.binding * term list) list -> theory ->
    35     (Attrib.binding * term list) list -> theory -> (term list * thm list list) * theory
    36     (term list * thm list list) * theory
    36   val axiomatization_cmd: (binding * string option * mixfix) list -> string list ->
    37   val axiomatization_cmd: (binding * string option * mixfix) list ->
    37     (Attrib.binding * string list) list -> theory -> (term list * thm list list) * theory
    38     (Attrib.binding * string list) list -> theory ->
       
    39     (term list * thm list list) * theory
       
    40   val axiom: Attrib.binding * term -> theory -> thm * theory
    38   val axiom: Attrib.binding * term -> theory -> thm * theory
    41   val definition:
    39   val definition: (binding * typ option * mixfix) option -> term list ->
    42     (binding * typ option * mixfix) option * (Attrib.binding * term) ->
    40     Attrib.binding * term -> local_theory -> (term * (string * thm)) * local_theory
    43     local_theory -> (term * (string * thm)) * local_theory
    41   val definition': (binding * typ option * mixfix) option -> term list ->
    44   val definition':
    42     Attrib.binding * term -> bool -> local_theory -> (term * (string * thm)) * local_theory
    45     (binding * typ option * mixfix) option * (Attrib.binding * term) ->
    43   val definition_cmd: (binding * string option * mixfix) option -> string list ->
    46     bool -> local_theory -> (term * (string * thm)) * local_theory
    44     Attrib.binding * string -> bool -> local_theory -> (term * (string * thm)) * local_theory
    47   val definition_cmd:
    45   val abbreviation: Syntax.mode -> (binding * typ option * mixfix) option -> term ->
    48     (binding * string option * mixfix) option * (Attrib.binding * string) ->
       
    49     bool -> local_theory -> (term * (string * thm)) * local_theory
       
    50   val abbreviation: Syntax.mode -> (binding * typ option * mixfix) option * term ->
       
    51     bool -> local_theory -> local_theory
    46     bool -> local_theory -> local_theory
    52   val abbreviation_cmd: Syntax.mode -> (binding * string option * mixfix) option * string ->
    47   val abbreviation_cmd: Syntax.mode -> (binding * string option * mixfix) option -> string ->
    53     bool -> local_theory -> local_theory
    48     bool -> local_theory -> local_theory
    54   val type_notation: bool -> Syntax.mode -> (typ * mixfix) list -> local_theory -> local_theory
    49   val type_notation: bool -> Syntax.mode -> (typ * mixfix) list -> local_theory -> local_theory
    55   val type_notation_cmd: bool -> Syntax.mode -> (string * mixfix) list ->
    50   val type_notation_cmd: bool -> Syntax.mode -> (string * mixfix) list ->
    56     local_theory -> local_theory
    51     local_theory -> local_theory
    57   val notation: bool -> Syntax.mode -> (term * mixfix) list -> local_theory -> local_theory
    52   val notation: bool -> Syntax.mode -> (term * mixfix) list -> local_theory -> local_theory
   139       Context_Position.reports params_ctxt
   134       Context_Position.reports params_ctxt
   140         (map (Binding.pos_of o #1) vars ~~
   135         (map (Binding.pos_of o #1) vars ~~
   141           map (Variable.markup_entity_def params_ctxt ##> Properties.remove Markup.kindN) xs);
   136           map (Variable.markup_entity_def params_ctxt ##> Properties.remove Markup.kindN) xs);
   142 
   137 
   143     val Asss0 =
   138     val Asss0 =
   144       (map o map) snd raw_specss
   139       map (fn (raw_concls, raw_prems) => raw_prems :: map snd raw_concls) raw_specss
   145       |> (burrow o burrow) (grouped 10 Par_List.map_independent (parse_prop params_ctxt));
   140       |> (burrow o burrow) (grouped 10 Par_List.map_independent (parse_prop params_ctxt));
   146     val names =
   141     val names =
   147       Variable.names_of (params_ctxt |> (fold o fold o fold) Variable.declare_term Asss0)
   142       Variable.names_of (params_ctxt |> (fold o fold o fold) Variable.declare_term Asss0)
   148       |> fold Name.declare xs;
   143       |> fold Name.declare xs;
   149 
   144 
   150     val (Asss1, _) = (fold_map o fold_map o fold_map) Term.free_dummy_patterns Asss0 names;
   145     val (Asss1, _) = (fold_map o fold_map o fold_map) Term.free_dummy_patterns Asss0 names;
   151     val idx = (fold o fold o fold) Term.maxidx_term Asss1 ~1 + 1;
   146     val idx = (fold o fold o fold) Term.maxidx_term Asss1 ~1 + 1;
   152 
   147 
   153     val (Asss2, _) =
   148     val (Asss2, _) =
   154       fold_map (fn Ass => fn i => (burrow (close_forms params_ctxt auto_close i []) Ass, i + 1))
   149       fold_map (fn prems :: conclss => fn i =>
   155         Asss1 idx;
   150         (burrow (close_forms params_ctxt auto_close i prems) conclss, i + 1)) Asss1 idx;
   156 
   151 
   157     val specs = burrow (Syntax.check_props params_ctxt) (flat Asss2);
   152     val specs = burrow (Syntax.check_props params_ctxt) (flat Asss2);
   158     val specs_ctxt = params_ctxt |> (fold o fold) Variable.declare_term specs;
   153     val specs_ctxt = params_ctxt |> (fold o fold) Variable.declare_term specs;
   159 
   154 
   160     val ps = specs_ctxt |> fold_map Proof_Context.inferred_param xs |> fst;
   155     val ps = specs_ctxt |> fold_map Proof_Context.inferred_param xs |> fst;
   161     val params = map2 (fn (b, _, mx) => fn (_, T) => ((b, T), mx)) vars ps;
   156     val params = map2 (fn (b, _, mx) => fn (_, T) => ((b, T), mx)) vars ps;
   162     val name_atts: Attrib.binding list =
   157     val name_atts: Attrib.binding list =
   163       map (fn ((name, atts), _) => (name, map (prep_att ctxt) atts)) (flat raw_specss);
   158       map (fn ((name, atts), _) => (name, map (prep_att ctxt) atts)) (maps #1 raw_specss);
   164 
   159 
   165     fun get_pos x =
   160     fun get_pos x =
   166       (case (maps o maps o maps) (get_positions specs_ctxt x) Asss2 of
   161       (case (maps o maps o maps) (get_positions specs_ctxt x) Asss2 of
   167         [] => Position.none
   162         [] => Position.none
   168       | pos :: _ => pos);
   163       | pos :: _ => pos);
   169   in (((params, name_atts ~~ specs), get_pos), specs_ctxt) end;
   164   in (((params, name_atts ~~ specs), get_pos), specs_ctxt) end;
   170 
   165 
   171 
   166 
   172 fun single_spec (a, prop) = [(a, [prop])];
   167 fun single_spec ((a, B), As) = ([(a, [B])], As);
   173 fun the_spec (a, [prop]) = (a, prop);
   168 fun the_spec (a, [prop]) = (a, prop);
   174 
   169 
   175 fun prep_spec prep_var parse_prop prep_att auto_close vars specs =
   170 fun prep_specs prep_var parse_prop prep_att auto_close vars specs =
   176   prepare prep_var parse_prop prep_att auto_close
   171   prepare prep_var parse_prop prep_att auto_close
   177     vars (map single_spec specs) #>> (apfst o apsnd) (map the_spec);
   172     vars (map single_spec specs) #>> (apfst o apsnd) (map the_spec);
   178 
   173 
   179 in
   174 in
   180 
   175 
   181 fun check_free_spec vars specs =
   176 fun check_spec xs As B =
   182   prep_spec Proof_Context.cert_var (K I) (K I) false vars specs;
   177   prep_specs Proof_Context.cert_var (K I) (K I) false xs [(B, As)] #>
   183 
   178   (apfst o apfst o apsnd) the_single;
   184 fun read_free_spec vars specs =
   179 
   185   prep_spec Proof_Context.read_var Syntax.parse_prop Attrib.check_src false vars specs;
   180 fun read_spec xs As B =
   186 
   181   prep_specs Proof_Context.read_var Syntax.parse_prop Attrib.check_src false xs [(B, As)] #>
   187 fun check_spec vars specs =
   182   (apfst o apfst o apsnd) the_single;
   188   prep_spec Proof_Context.cert_var (K I) (K I) true vars specs #> apfst fst;
   183 
   189 
   184 type multi_specs = ((Attrib.binding * term) * term list) list;
   190 fun read_spec vars specs =
   185 type multi_specs_cmd = ((Attrib.binding * string) * string list) list;
   191   prep_spec Proof_Context.read_var Syntax.parse_prop Attrib.check_src true vars specs #> apfst fst;
   186 
   192 
   187 fun check_multi_specs xs specs =
   193 fun check_specification vars specs =
   188   prep_specs Proof_Context.cert_var (K I) (K I) true xs specs #>> #1;
   194   prepare Proof_Context.cert_var (K I) (K I) true vars [specs] #> apfst fst
   189 
   195 
   190 fun read_multi_specs xs specs =
   196 fun read_specification vars specs =
   191   prep_specs Proof_Context.read_var Syntax.parse_prop Attrib.check_src true xs specs #>> #1;
   197   prepare Proof_Context.read_var Syntax.parse_prop Attrib.check_src true vars [specs] #> apfst fst;
   192 
       
   193 fun check_specification xs As Bs =
       
   194   prepare Proof_Context.cert_var (K I) (K I) true xs [(Bs, As)] #>> #1;
       
   195 
       
   196 fun read_specification xs As Bs =
       
   197   prepare Proof_Context.read_var Syntax.parse_prop Attrib.check_src true xs [(Bs, As)] #>> #1;
   198 
   198 
   199 end;
   199 end;
   200 
   200 
   201 
   201 
   202 (* axiomatization -- within global theory *)
   202 (* axiomatization -- within global theory *)
   203 
   203 
   204 fun gen_axioms prep raw_vars raw_specs thy =
   204 fun gen_axioms prep raw_decls raw_prems raw_concls thy =
   205   let
   205   let
   206     val ((vars, specs), _) = prep raw_vars raw_specs (Proof_Context.init_global thy);
   206     val ((decls, specs), _) = prep raw_decls raw_prems raw_concls (Proof_Context.init_global thy);
   207     val xs = map (fn ((b, T), _) => (Variable.check_name b, T)) vars;
   207     val xs = map (fn ((b, T), _) => (Variable.check_name b, T)) decls;
   208 
   208 
   209     (*consts*)
   209     (*consts*)
   210     val (consts, consts_thy) = thy |> fold_map Theory.specify_const vars;
   210     val (consts, consts_thy) = thy |> fold_map Theory.specify_const decls;
   211     val subst = Term.subst_atomic (map Free xs ~~ consts);
   211     val subst = Term.subst_atomic (map Free xs ~~ consts);
   212 
   212 
   213     (*axioms*)
   213     (*axioms*)
   214     val (axioms, axioms_thy) = (specs, consts_thy) |-> fold_map (fn ((b, atts), props) =>
   214     val (axioms, axioms_thy) = (specs, consts_thy) |-> fold_map (fn ((b, atts), props) =>
   215         fold_map Thm.add_axiom_global
   215         fold_map Thm.add_axiom_global
   226   in ((consts, map #2 facts), Local_Theory.exit_global facts_lthy) end;
   226   in ((consts, map #2 facts), Local_Theory.exit_global facts_lthy) end;
   227 
   227 
   228 val axiomatization = gen_axioms check_specification;
   228 val axiomatization = gen_axioms check_specification;
   229 val axiomatization_cmd = gen_axioms read_specification;
   229 val axiomatization_cmd = gen_axioms read_specification;
   230 
   230 
   231 fun axiom (b, ax) = axiomatization [] [(b, [ax])] #>> (hd o hd o snd);
   231 fun axiom (b, ax) = axiomatization [] [] [(b, [ax])] #>> (hd o hd o snd);
   232 
   232 
   233 
   233 
   234 (* definition *)
   234 (* definition *)
   235 
   235 
   236 fun gen_def prep (raw_var, raw_spec) int lthy =
   236 fun gen_def prep raw_var raw_prems raw_spec int lthy =
   237   let
   237   let
   238     val ((vars, [((raw_name, atts), prop)]), get_pos) =
   238     val ((vars, ((raw_name, atts), prop)), get_pos) =
   239       fst (prep (the_list raw_var) [raw_spec] lthy);
   239       fst (prep (the_list raw_var) raw_prems raw_spec lthy);
   240     val (((x, T), rhs), prove) = Local_Defs.derived_def lthy {conditional = true} prop;
   240     val (((x, T), rhs), prove) = Local_Defs.derived_def lthy {conditional = true} prop;
   241     val _ = Name.reject_internal (x, []);
   241     val _ = Name.reject_internal (x, []);
   242     val (b, mx) =
   242     val (b, mx) =
   243       (case vars of
   243       (case vars of
   244         [] => (Binding.make (x, get_pos x), NoSyn)
   244         [] => (Binding.make (x, get_pos x), NoSyn)
   264     val _ =
   264     val _ =
   265       Proof_Display.print_consts int (Position.thread_data ()) lthy4
   265       Proof_Display.print_consts int (Position.thread_data ()) lthy4
   266         (member (op =) (Term.add_frees lhs' [])) [(x, T)];
   266         (member (op =) (Term.add_frees lhs' [])) [(x, T)];
   267   in ((lhs, (def_name, th')), lthy4) end;
   267   in ((lhs, (def_name, th')), lthy4) end;
   268 
   268 
   269 val definition' = gen_def check_free_spec;
   269 val definition' = gen_def check_spec;
   270 fun definition spec = definition' spec false;
   270 fun definition xs As B = definition' xs As B false;
   271 val definition_cmd = gen_def read_free_spec;
   271 val definition_cmd = gen_def read_spec;
   272 
   272 
   273 
   273 
   274 (* abbreviation *)
   274 (* abbreviation *)
   275 
   275 
   276 fun gen_abbrev prep mode (raw_var, raw_prop) int lthy =
   276 fun gen_abbrev prep mode raw_var raw_prop int lthy =
   277   let
   277   let
   278     val lthy1 = lthy
   278     val lthy1 = lthy
   279       |> Proof_Context.set_syntax_mode mode;
   279       |> Proof_Context.set_syntax_mode mode;
   280     val (((vars, [(_, prop)]), get_pos), _) =
   280     val (((vars, (_, prop)), get_pos), _) =
   281       prep (the_list raw_var) [(Attrib.empty_binding, raw_prop)]
   281       prep (the_list raw_var) [] (Attrib.empty_binding, raw_prop)
   282         (lthy1 |> Proof_Context.set_mode Proof_Context.mode_abbrev);
   282         (lthy1 |> Proof_Context.set_mode Proof_Context.mode_abbrev);
   283     val ((x, T), rhs) = Local_Defs.abs_def (#2 (Local_Defs.cert_def lthy1 prop));
   283     val ((x, T), rhs) = Local_Defs.abs_def (#2 (Local_Defs.cert_def lthy1 prop));
   284     val _ = Name.reject_internal (x, []);
   284     val _ = Name.reject_internal (x, []);
   285     val (b, mx) =
   285     val (b, mx) =
   286       (case vars of
   286       (case vars of
   297       |> Proof_Context.restore_syntax_mode lthy;
   297       |> Proof_Context.restore_syntax_mode lthy;
   298 
   298 
   299     val _ = Proof_Display.print_consts int (Position.thread_data ()) lthy2 (K false) [(x, T)];
   299     val _ = Proof_Display.print_consts int (Position.thread_data ()) lthy2 (K false) [(x, T)];
   300   in lthy2 end;
   300   in lthy2 end;
   301 
   301 
   302 val abbreviation = gen_abbrev check_free_spec;
   302 val abbreviation = gen_abbrev check_spec;
   303 val abbreviation_cmd = gen_abbrev read_free_spec;
   303 val abbreviation_cmd = gen_abbrev read_spec;
   304 
   304 
   305 
   305 
   306 (* notation *)
   306 (* notation *)
   307 
   307 
   308 local
   308 local