src/Pure/Isar/specification.ML
changeset 63063 c9605a284fba
parent 63041 cb495c4807b3
child 63064 2f18172214c8
equal deleted inserted replaced
63062:60406bf310f8 63063:c9605a284fba
   103 
   103 
   104 (* prepare specification *)
   104 (* prepare specification *)
   105 
   105 
   106 local
   106 local
   107 
   107 
   108 fun close_forms ctxt i As =
   108 fun close_forms ctxt auto_close i prems concls =
   109   let
   109   let
   110     val xs = rev (fold (Variable.add_free_names ctxt) As []);
   110     val xs =
       
   111       if auto_close then rev (fold (Variable.add_free_names ctxt) (concls @ prems) [])
       
   112       else [];
   111     val types =
   113     val types =
   112       map (Type_Infer.param i o rpair []) (Name.invent Name.context Name.aT (length xs));
   114       map (Type_Infer.param i o rpair []) (Name.invent Name.context Name.aT (length xs));
   113     val uniform_typing = AList.lookup (op =) (xs ~~ types);
   115     val uniform_typing = AList.lookup (op =) (xs ~~ types);
   114     val close = fold_rev (Logic.dependent_all_constraint uniform_typing) (xs ~~ xs);
   116   in map (Logic.close_prop_constraint uniform_typing (xs ~~ xs) prems) concls end;
   115   in map close As end;
       
   116 
   117 
   117 fun get_positions ctxt x =
   118 fun get_positions ctxt x =
   118   let
   119   let
   119     fun get Cs (Const ("_type_constraint_", C) $ t) = get (C :: Cs) t
   120     fun get Cs (Const ("_type_constraint_", C) $ t) = get (C :: Cs) t
   120       | get _ (t $ u) = get [] t @ get [] u
   121       | get _ (t $ u) = get [] t @ get [] u
   125               (T :: map (Type.constraint_type ctxt) Cs)
   126               (T :: map (Type.constraint_type ctxt) Cs)
   126           else []
   127           else []
   127       | get _ _ = [];
   128       | get _ _ = [];
   128   in get [] end;
   129   in get [] end;
   129 
   130 
   130 fun prepare prep_var parse_prop prep_att do_close raw_vars raw_specss ctxt =
   131 fun prepare prep_var parse_prop prep_att auto_close raw_vars raw_specss ctxt =
   131   let
   132   let
   132     val (vars, vars_ctxt) = ctxt |> fold_map prep_var raw_vars;
   133     val (vars, vars_ctxt) = ctxt |> fold_map prep_var raw_vars;
   133     val (xs, params_ctxt) = vars_ctxt
   134     val (xs, params_ctxt) = vars_ctxt
   134       |> Context_Position.set_visible false
   135       |> Context_Position.set_visible false
   135       |> Proof_Context.add_fixes vars
   136       |> Proof_Context.add_fixes vars
   137     val _ =
   138     val _ =
   138       Context_Position.reports params_ctxt
   139       Context_Position.reports params_ctxt
   139         (map (Binding.pos_of o #1) vars ~~
   140         (map (Binding.pos_of o #1) vars ~~
   140           map (Variable.markup_entity_def params_ctxt ##> Properties.remove Markup.kindN) xs);
   141           map (Variable.markup_entity_def params_ctxt ##> Properties.remove Markup.kindN) xs);
   141 
   142 
   142     val Asss =
   143     val Asss0 =
   143       (map o map) snd raw_specss
   144       (map o map) snd raw_specss
   144       |> (burrow o burrow) (grouped 10 Par_List.map_independent (parse_prop params_ctxt));
   145       |> (burrow o burrow) (grouped 10 Par_List.map_independent (parse_prop params_ctxt));
   145     val names = Variable.names_of (params_ctxt |> (fold o fold o fold) Variable.declare_term Asss)
   146     val names =
       
   147       Variable.names_of (params_ctxt |> (fold o fold o fold) Variable.declare_term Asss0)
   146       |> fold Name.declare xs;
   148       |> fold Name.declare xs;
   147     val Asss' = #1 ((fold_map o fold_map o fold_map) Term.free_dummy_patterns Asss names);
   149 
   148     val idx = (fold o fold o fold) Term.maxidx_term Asss' ~1 + 1;
   150     val (Asss1, _) = (fold_map o fold_map o fold_map) Term.free_dummy_patterns Asss0 names;
   149 
   151     val idx = (fold o fold o fold) Term.maxidx_term Asss1 ~1 + 1;
   150     val specs =
   152 
   151       (if do_close then
   153     val (Asss2, _) =
   152         #1 (fold_map
   154       fold_map (fn Ass => fn i => (burrow (close_forms params_ctxt auto_close i []) Ass, i + 1))
   153             (fn Ass => fn i => (burrow (close_forms params_ctxt i) Ass, i + 1)) Asss' idx)
   155         Asss1 idx;
   154       else Asss')
   156 
   155       |> flat |> burrow (Syntax.check_props params_ctxt);
   157     val specs = burrow (Syntax.check_props params_ctxt) (flat Asss2);
   156     val specs_ctxt = params_ctxt |> (fold o fold) Variable.declare_term specs;
   158     val specs_ctxt = params_ctxt |> (fold o fold) Variable.declare_term specs;
   157 
   159 
   158     val ps = specs_ctxt |> fold_map Proof_Context.inferred_param xs |> fst;
   160     val ps = specs_ctxt |> fold_map Proof_Context.inferred_param xs |> fst;
   159     val params = map2 (fn (b, _, mx) => fn (_, T) => ((b, T), mx)) vars ps;
   161     val params = map2 (fn (b, _, mx) => fn (_, T) => ((b, T), mx)) vars ps;
   160     val name_atts: Attrib.binding list =
   162     val name_atts: Attrib.binding list =
   161       map (fn ((name, atts), _) => (name, map (prep_att ctxt) atts)) (flat raw_specss);
   163       map (fn ((name, atts), _) => (name, map (prep_att ctxt) atts)) (flat raw_specss);
   162 
   164 
   163     fun get_pos x =
   165     fun get_pos x =
   164       if do_close then Position.none
   166       (case (maps o maps o maps) (get_positions specs_ctxt x) Asss2 of
   165       else
   167         [] => Position.none
   166         (case (maps o maps o maps) (get_positions specs_ctxt x) Asss' of
   168       | pos :: _ => pos);
   167           [] => Position.none
       
   168         | pos :: _ => pos);
       
   169   in (((params, name_atts ~~ specs), get_pos), specs_ctxt) end;
   169   in (((params, name_atts ~~ specs), get_pos), specs_ctxt) end;
   170 
   170 
   171 
   171 
   172 fun single_spec (a, prop) = [(a, [prop])];
   172 fun single_spec (a, prop) = [(a, [prop])];
   173 fun the_spec (a, [prop]) = (a, prop);
   173 fun the_spec (a, [prop]) = (a, prop);
   174 
   174 
   175 fun prep_spec prep_var parse_prop prep_att do_close vars specs =
   175 fun prep_spec prep_var parse_prop prep_att auto_close vars specs =
   176   prepare prep_var parse_prop prep_att do_close
   176   prepare prep_var parse_prop prep_att auto_close
   177     vars (map single_spec specs) #>> (apfst o apsnd) (map the_spec);
   177     vars (map single_spec specs) #>> (apfst o apsnd) (map the_spec);
   178 
   178 
   179 in
   179 in
   180 
   180 
   181 fun check_free_spec vars specs =
   181 fun check_free_spec vars specs =