src/Pure/Thy/thy_info.ML
changeset 15158 2281784015a5
parent 15065 9feac0b7f935
child 15531 08c8dad8e399
equal deleted inserted replaced
15157:faeb23489b73 15158:2281784015a5
    39   val touch_all_thys: unit -> unit
    39   val touch_all_thys: unit -> unit
    40   val load_file: bool -> Path.T -> unit
    40   val load_file: bool -> Path.T -> unit
    41   val use: string -> unit
    41   val use: string -> unit
    42   val quiet_update_thy: bool -> string -> unit
    42   val quiet_update_thy: bool -> string -> unit
    43   val pretend_use_thy_only: string -> unit
    43   val pretend_use_thy_only: string -> unit
    44   val begin_theory: (string -> string list -> (Path.T * bool) list -> theory -> theory) ->
    44   val begin_theory: (Path.T option -> string -> string list ->
       
    45       (Path.T * bool) list -> theory -> theory) ->
    45     bool -> string -> string list -> (Path.T * bool) list -> theory
    46     bool -> string -> string list -> (Path.T * bool) list -> theory
    46   val end_theory: theory -> theory
    47   val end_theory: theory -> theory
    47   val finish: unit -> unit
    48   val finish: unit -> unit
    48   val register_theory: theory -> unit
    49   val register_theory: theory -> unit
    49 end;
    50 end;
   224   else ();
   225   else ();
   225 
   226 
   226 
   227 
   227 (* load_file *)
   228 (* load_file *)
   228 
   229 
       
   230 val opt_path = apsome (Path.dir o fst o ThyLoad.get_thy);
       
   231 fun opt_path' (d : deps option) = if_none (apsome (opt_path o #master) d) None;
       
   232 fun opt_path'' d = if_none (apsome opt_path' d) None;
       
   233 
   229 local
   234 local
   230 
   235 
   231 fun provide path name info (deps as Some {present, outdated, master, files}) =
   236 fun provide path name info (deps as Some {present, outdated, master, files}) =
   232      (if exists (equal path o #1) files then ()
   237      (if exists (equal path o #1) files then ()
   233       else warning (loader_msg "undeclared dependency of theory" [name] ^
   238       else warning (loader_msg "undeclared dependency of theory" [name] ^
   235       Some (make_deps present outdated master (overwrite (files, (path, Some info)))))
   240       Some (make_deps present outdated master (overwrite (files, (path, Some info)))))
   236   | provide _ _ _ None = None;
   241   | provide _ _ _ None = None;
   237 
   242 
   238 fun run_file path =
   243 fun run_file path =
   239   (case apsome PureThy.get_name (Context.get_context ()) of
   244   (case apsome PureThy.get_name (Context.get_context ()) of
   240     None => (ThyLoad.load_file path; ())
   245     None => (ThyLoad.load_file None path; ())
   241   | Some name =>
   246   | Some name => (case lookup_deps name of
   242       if known_thy name then change_deps name (provide path name (ThyLoad.load_file path))
   247       Some deps => change_deps name (provide path name
   243       else (ThyLoad.load_file path; ()));
   248         (ThyLoad.load_file (opt_path' deps) path))
       
   249     | None => (ThyLoad.load_file None path; ())));
   244 
   250 
   245 in
   251 in
   246 
   252 
   247 fun load_file time path =
   253 fun load_file time path =
   248   if time then
   254   if time then
   295 
   301 
   296 fun load_deps ml dir name =
   302 fun load_deps ml dir name =
   297   let val (master, (parents, files)) = ThyLoad.deps_thy dir name ml
   303   let val (master, (parents, files)) = ThyLoad.deps_thy dir name ml
   298   in (Some (init_deps (Some master) files), parents) end;
   304   in (Some (init_deps (Some master) files), parents) end;
   299 
   305 
   300 fun file_current (_, None) = false
   306 fun file_current master (_, None) = false
   301   | file_current (path, info) = (info = ThyLoad.check_file path);
   307   | file_current master (path, info) =
       
   308       (info = ThyLoad.check_file (opt_path master) path);
   302 
   309 
   303 fun current_deps ml strict dir name =
   310 fun current_deps ml strict dir name =
   304   (case lookup_deps name of
   311   (case lookup_deps name of
   305     None => (false, load_deps ml dir name)
   312     None => (false, load_deps ml dir name)
   306   | Some deps =>
   313   | Some deps =>
   307       let val same_deps = (None, thy_graph Graph.imm_preds name) in
   314       let
       
   315         fun get_name s = (case opt_path'' (lookup_deps s) of None => s
       
   316           | Some p => Path.pack (Path.append p (Path.basic s)));
       
   317         val same_deps = (None, map get_name (thy_graph Graph.imm_preds name))
       
   318       in
   308         (case deps of
   319         (case deps of
   309           None => (true, same_deps)
   320           None => (true, same_deps)
   310         | Some {present, outdated, master, files} =>
   321         | Some {present, outdated, master, files} =>
   311             if present andalso not strict then (true, same_deps)
   322             if present andalso not strict then (true, same_deps)
   312             else
   323             else
   313               let val master' = Some (ThyLoad.check_thy dir name ml) in
   324               let val master' = Some (ThyLoad.check_thy dir name ml) in
   314                 if master <> master' then (false, load_deps ml dir name)
   325                 if master <> master' then (false, load_deps ml dir name)
   315                 else (not outdated andalso forall file_current files, same_deps)
   326                 else (not outdated andalso forall (file_current master') files, same_deps)
   316               end)
   327               end)
   317       end);
   328       end);
   318 
   329 
   319 fun require_thy really ml time strict keep_strict initiators prfx (visited, str) =
   330 fun require_thy really ml time strict keep_strict initiators prfx (visited, str) =
   320   let
   331   let
   331           (name :: initiators);
   342           (name :: initiators);
   332 
   343 
   333         val (current, (new_deps, parents)) = current_deps ml strict dir name handle ERROR =>
   344         val (current, (new_deps, parents)) = current_deps ml strict dir name handle ERROR =>
   334           error (loader_msg "the error(s) above occurred while examining theory" [name] ^
   345           error (loader_msg "the error(s) above occurred while examining theory" [name] ^
   335             (if null initiators then "" else required_by "\n" initiators));
   346             (if null initiators then "" else required_by "\n" initiators));
   336         val dir' = (case new_deps of
   347         val dir' = if_none (opt_path'' new_deps) dir;
   337             None => dir
       
   338           | Some (Some {master = Some m, ...}) => Path.dir (fst (ThyLoad.get_thy m)));
       
   339         val (visited', parent_results) = foldl_map (req_parent dir') (name :: visited, parents);
   348         val (visited', parent_results) = foldl_map (req_parent dir') (name :: visited, parents);
   340 
   349 
   341         val thy = if not really then Some (get_theory name) else None;
   350         val thy = if not really then Some (get_theory name) else None;
   342         val result =
   351         val result =
   343           if current andalso forall #1 parent_results then true
   352           if current andalso forall #1 parent_results then true
   348              load_thy really ml (time orelse ! Output.timing) initiators dir name;
   357              load_thy really ml (time orelse ! Output.timing) initiators dir name;
   349              false);
   358              false);
   350       in (visited', (result, name)) end
   359       in (visited', (result, name)) end
   351   end;
   360   end;
   352 
   361 
   353 fun gen_use_thy req s =
   362 fun gen_use_thy' req prfx s =
   354   let val (_, (_, name)) = req [] Path.current ([], s)
   363   let val (_, (_, name)) = req [] prfx ([], s)
   355   in Context.context (get_theory name) end;
   364   in Context.context (get_theory name) end;
   356 
   365 
       
   366 fun gen_use_thy req = gen_use_thy' req Path.current;
       
   367 
   357 fun warn_finished f name = (check_unfinished warning name; f name);
   368 fun warn_finished f name = (check_unfinished warning name; f name);
   358 
   369 
   359 in
   370 in
   360 
   371 
   361 val weak_use_thy        = gen_use_thy (require_thy true true false false false);
   372 val weak_use_thy         = gen_use_thy' (require_thy true true false false false);
   362 fun quiet_update_thy ml = gen_use_thy (require_thy true ml false true true);
   373 fun quiet_update_thy' ml = gen_use_thy' (require_thy true ml false true true);
       
   374 fun quiet_update_thy ml  = gen_use_thy (require_thy true ml false true true);
   363 
   375 
   364 val use_thy          = warn_finished (gen_use_thy (require_thy true true false true false));
   376 val use_thy          = warn_finished (gen_use_thy (require_thy true true false true false));
   365 val time_use_thy     = warn_finished (gen_use_thy (require_thy true true true true false));
   377 val time_use_thy     = warn_finished (gen_use_thy (require_thy true true true true false));
   366 val use_thy_only     = warn_finished (gen_use_thy (require_thy true false false true false));
   378 val use_thy_only     = warn_finished (gen_use_thy (require_thy true false false true false));
   367 val update_thy       = warn_finished (gen_use_thy (require_thy true true false true true));
   379 val update_thy       = warn_finished (gen_use_thy (require_thy true true false true true));
   386 (* begin / end theory *)
   398 (* begin / end theory *)
   387 
   399 
   388 fun begin_theory present upd name parents paths =
   400 fun begin_theory present upd name parents paths =
   389   let
   401   let
   390     val bparents = map base_of_path parents;
   402     val bparents = map base_of_path parents;
   391     val assert_thy = if upd then quiet_update_thy true else weak_use_thy;
   403     val dir' = opt_path'' (lookup_deps name);
       
   404     val dir = if_none dir' Path.current;
       
   405     val assert_thy = if upd then quiet_update_thy' true dir else weak_use_thy dir;
   392     val _ = check_unfinished error name;
   406     val _ = check_unfinished error name;
   393     val _ = seq assert_thy parents;
   407     val _ = seq assert_thy parents;
   394     val theory = PureThy.begin_theory name (map get_theory bparents);
   408     val theory = PureThy.begin_theory name (map get_theory bparents);
   395     val deps =
   409     val deps =
   396       if known_thy name then get_deps name
   410       if known_thy name then get_deps name
   397       else (init_deps None (map #1 paths));   (*records additional ML files only!*)
   411       else (init_deps None (map #1 paths));   (*records additional ML files only!*)
   398     val use_paths = mapfilter (fn (x, true) => Some x | _ => None) paths;
   412     val use_paths = mapfilter (fn (x, true) => Some x | _ => None) paths;
   399 
   413 
   400     val _ = change_thys (update_node name bparents (deps, Some (Theory.copy theory)));
   414     val _ = change_thys (update_node name bparents (deps, Some (Theory.copy theory)));
   401     val theory' = theory |> present name bparents paths;
   415     val theory' = theory |> present dir' name bparents paths;
   402     val _ = put_theory name (Theory.copy theory');
   416     val _ = put_theory name (Theory.copy theory');
   403     val ((), theory'') = Context.pass_theory theory' (seq (load_file false)) use_paths;
   417     val ((), theory'') = Context.pass_theory theory' (seq (load_file false)) use_paths;
   404     val _ = put_theory name (Theory.copy theory'');
   418     val _ = put_theory name (Theory.copy theory'');
   405   in theory'' end;
   419   in theory'' end;
   406 
   420