339 >> (fn (((module_name, raw_datatypes), raw_functions), some_file) => Toplevel.theory |
340 >> (fn (((module_name, raw_datatypes), raw_functions), some_file) => Toplevel.theory |
340 (code_reflect_cmd raw_datatypes raw_functions module_name some_file))); |
341 (code_reflect_cmd raw_datatypes raw_functions module_name some_file))); |
341 |
342 |
342 end; (*local*) |
343 end; (*local*) |
343 |
344 |
|
345 |
|
346 (** using external SML files as substitute for proper definitions -- only for polyml! **) |
|
347 |
|
348 local |
|
349 |
|
350 structure Loaded_Values = Theory_Data( |
|
351 type T = string list |
|
352 val empty = [] |
|
353 val merge = merge (op =) |
|
354 val extend = I |
|
355 ); |
|
356 |
|
357 fun notify_val (string, value) = |
|
358 let |
|
359 val _ = #enterVal ML_Env.name_space (string, value); |
|
360 val _ = Context.>> ((Context.map_theory o Loaded_Values.map) (insert (op =) string)); |
|
361 in () end; |
|
362 |
|
363 fun abort _ = error "Only value bindings allowed."; |
|
364 |
|
365 val notifying_context : use_context = |
|
366 {tune_source = #tune_source ML_Env.local_context, |
|
367 name_space = |
|
368 {lookupVal = #lookupVal ML_Env.name_space, |
|
369 lookupType = #lookupType ML_Env.name_space, |
|
370 lookupFix = #lookupFix ML_Env.name_space, |
|
371 lookupStruct = #lookupStruct ML_Env.name_space, |
|
372 lookupSig = #lookupSig ML_Env.name_space, |
|
373 lookupFunct = #lookupFunct ML_Env.name_space, |
|
374 enterVal = notify_val, |
|
375 enterType = abort, |
|
376 enterFix = abort, |
|
377 enterStruct = abort, |
|
378 enterSig = abort, |
|
379 enterFunct = abort, |
|
380 allVal = #allVal ML_Env.name_space, |
|
381 allType = #allType ML_Env.name_space, |
|
382 allFix = #allFix ML_Env.name_space, |
|
383 allStruct = #allStruct ML_Env.name_space, |
|
384 allSig = #allSig ML_Env.name_space, |
|
385 allFunct = #allFunct ML_Env.name_space}, |
|
386 str_of_pos = #str_of_pos ML_Env.local_context, |
|
387 print = #print ML_Env.local_context, |
|
388 error = #error ML_Env.local_context}; |
|
389 |
|
390 in |
|
391 |
|
392 fun use_file filepath thy = |
|
393 let |
|
394 val thy' = Loaded_Values.put [] thy; |
|
395 val _ = Context.set_thread_data ((SOME o Context.Theory) thy'); |
|
396 val _ = Secure.use_text notifying_context |
|
397 (0, Path.implode filepath) false (File.read filepath); |
|
398 val thy'' = (Context.the_theory o the) (Context.thread_data ()) |
|
399 val names = Loaded_Values.get thy'' |
|
400 in (names, thy'') end; |
|
401 |
|
402 end; |
|
403 |
|
404 fun add_definiendum (ml_name, (b, T)) thy = |
|
405 thy |
|
406 |> Code_Target.add_reserved target ml_name |
|
407 |> Specification.axiomatization [(b, SOME T, NoSyn)] [] |
|
408 |-> (fn ([Const (const, _)], _) => |
|
409 Code_Target.add_const_syntax target const |
|
410 (SOME (Code_Printer.simple_const_syntax (0, (K o K o K o Code_Printer.str) ml_name)))); |
|
411 |
|
412 fun process_file filepath (definienda, thy) = |
|
413 let |
|
414 val (ml_names, thy') = use_file filepath thy; |
|
415 val superfluous = subtract (fn ((name1, _), name2) => name1 = name2) definienda ml_names; |
|
416 val _ = if null superfluous then () |
|
417 else error ("Value binding(s) " ^ commas_quote superfluous |
|
418 ^ " found in external file " ^ quote (Path.implode filepath) |
|
419 ^ " not present among the given contants binding(s)."); |
|
420 val these_definienda = AList.make (the o AList.lookup (op =) definienda) ml_names; |
|
421 val thy'' = fold add_definiendum these_definienda thy'; |
|
422 val definienda' = fold (AList.delete (op =)) ml_names definienda; |
|
423 in (definienda', thy'') end; |
|
424 |
|
425 fun polyml_as_definition bTs filepaths thy = |
|
426 let |
|
427 val definienda = map (fn bT => ((Binding.name_of o fst) bT, bT)) bTs; |
|
428 val (remaining, thy') = fold process_file filepaths (definienda, thy); |
|
429 val _ = if null remaining then () |
|
430 else error ("Constant binding(s) " ^ commas_quote (map fst remaining) |
|
431 ^ " not present in external file(s)."); |
|
432 in thy' end; |
|
433 |
344 end; (*struct*) |
434 end; (*struct*) |