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 |