"export_code ... file_prefix ..." is the preferred way to produce output within the logical file-system within the theory context, as well as session exports;
authorwenzelm
Thu, 28 Mar 2019 21:24:55 +0100
changeset 70009 435fb018e8ee
parent 70008 7aaebfcf3134
child 70010 499896e3a7b0
"export_code ... file_prefix ..." is the preferred way to produce output within the logical file-system within the theory context, as well as session exports; "export_code ... file" is legacy, the empty name form has been discontinued; updated examples;
NEWS
src/Doc/Codegen/Introduction.thy
src/Doc/Isar_Ref/HOL_Specific.thy
src/HOL/Code_Numeral.thy
src/HOL/Quotient_Examples/Lift_DList.thy
src/HOL/Quotient_Examples/Lift_FSet.thy
src/HOL/Quotient_Examples/Lift_Set.thy
src/HOL/ex/Code_Lazy_Demo.thy
src/Pure/Pure.thy
src/Pure/Thy/export.ML
src/Tools/Code/code_target.ML
src/Tools/Code_Generator.thy
--- a/NEWS	Thu Mar 28 21:22:44 2019 +0100
+++ b/NEWS	Thu Mar 28 21:24:55 2019 +0100
@@ -132,12 +132,21 @@
 Minor INCOMPATIBILITY, prefer combinators Named_Target.theory_map[_result]
 to lift specifications to the global theory level.
 
-* Code generation: command 'export_code' without file keyword exports
-code as regular theory export, which can be materialized using the
-command-line tools "isabelle export" or "isabelle build -e" (with
-'export_files' in the session ROOT), or browsed in Isabelle/jEdit via
-the "isabelle-export:" file-system. To get generated code dumped into
-output, use "file \<open>\<close>". Minor INCOMPATIBILITY.
+* Command 'export_code' produces output as logical files within the
+theory context, as well as session exports that can be materialized
+using the command-line tools "isabelle export" or "isabelle build -e"
+(with 'export_files' in the session ROOT), or browsed in Isabelle/jEdit
+via the "isabelle-export:" file-system. A 'file_prefix' argument allows
+to specify an explicit prefix, the default is "export" with a
+consecutive number within each theory. The overall prefix "code" is
+always prepended.
+
+* Command 'export_code': the 'file' argument is now legacy and will be
+removed soon: writing to the physical file-system is not well-defined in
+a reactive/parallel application like Isabelle. The empty 'file' has been
+discontinued already: it has been superseded by the file-browser in
+Isabelle/jEdit with "isabelle-export:" as file-system. Minor
+INCOMPATIBILITY.
 
 * Code generation for OCaml: proper strings are used for literals.
 Minor INCOMPATIBILITY.
--- a/src/Doc/Codegen/Introduction.thy	Thu Mar 28 21:22:44 2019 +0100
+++ b/src/Doc/Codegen/Introduction.thy	Thu Mar 28 21:24:55 2019 +0100
@@ -69,7 +69,7 @@
 text \<open>\noindent Then we can generate code e.g.~for \<open>SML\<close> as follows:\<close>
 
 export_code %quote empty dequeue enqueue in SML
-  module_name Example file \<open>$ISABELLE_TMP/example.ML\<close>
+  module_name Example file_prefix example
 
 text \<open>\noindent resulting in the following code:\<close>
 
@@ -78,19 +78,29 @@
 \<close>
 
 text \<open>
-  \noindent The @{command_def export_code} command takes a
-  space-separated list of constants for which code shall be generated;
-  anything else needed for those is added implicitly.  Then follows a
-  target language identifier and a freely chosen module name.  A file
-  name denotes the destination to store the generated code.  Note that
-  the semantics of the destination depends on the target language: for
-  \<open>SML\<close>, \<open>OCaml\<close> and \<open>Scala\<close> it denotes a \emph{file},
-  for \<open>Haskell\<close> it denotes a \emph{directory} where a file named as the
-  module name (with extension \<open>.hs\<close>) is written:
+  \noindent The @{command_def export_code} command takes a space-separated
+  list of constants for which code shall be generated; anything else needed
+  for those is added implicitly. Then follows a target language identifier
+  and a freely chosen \<^theory_text>\<open>module_name\<close>. A \<^theory_text>\<open>file_prefix\<close> introduces
+  sub-directory structure for the output of logical files (within the
+  theory context), as well as session exports; the default is \<^verbatim>\<open>export\<close>
+  with a consecutive number within the current theory. The prefix \<^verbatim>\<open>code\<close>
+  is always prepended to the code output directory. For \<open>SML\<close>, \<open>OCaml\<close> and
+  \<open>Scala\<close> the result is a single file, for \<open>Haskell\<close> each module gets its
+  own file with the module name and extension \<^verbatim>\<open>.hs\<close>. Here is an example:\<^footnote>\<open>
+  The exports may be explored within the Isabelle/jEdit Prover IDE using
+  the file-browser on the \<^verbatim>\<open>isabelle-export:\<close> virtual file-system.\<close>
+
+  %FIXME old/new "name"
+  %name denotes the destination to store the generated
+  %code. Note that the semantics of the destination depends on the target
+  %language: for \<open>SML\<close>, \<open>OCaml\<close> and \<open>Scala\<close> it denotes a \emph{file}, for
+  %\<open>Haskell\<close> it denotes a \emph{directory} where a file named as the module
+  %name (with extension \<open>.hs\<close>) is written:
 \<close>
 
 export_code %quote empty dequeue enqueue in Haskell
-  module_name Example file \<open>$ISABELLE_TMP/examples/\<close>
+  module_name Example file_prefix examples
 
 text \<open>
   \noindent This is the corresponding code:
--- a/src/Doc/Isar_Ref/HOL_Specific.thy	Thu Mar 28 21:22:44 2019 +0100
+++ b/src/Doc/Isar_Ref/HOL_Specific.thy	Thu Mar 28 21:24:55 2019 +0100
@@ -2284,8 +2284,8 @@
     @@{command (HOL) export_code} @'open'? \<newline> (const_expr+) (export_target*)
     ;
     export_target:
-      @'in' target (@'module_name' @{syntax string})? \<newline>
-      (@'file' @{syntax string})? ('(' args ')')?
+      @'in' target (@'module_name' @{syntax name})? \<newline>
+      (@'file_prefix' @{syntax embedded})? ('(' args ')')?
     ;
     target: 'SML' | 'OCaml' | 'Haskell' | 'Scala' | 'Eval'
     ;
@@ -2390,13 +2390,12 @@
   generated. Alternatively, a module name may be specified after the @{keyword
   "module_name"} keyword; then \<^emph>\<open>all\<close> code is placed in this module.
 
-  By default, generated code is treated as theory export which can be
-  explicitly retrieved using @{tool_ref export}. For diagnostic purposes
-  generated code can also be written to the file system using @{keyword "file"};
-  for \<^emph>\<open>SML\<close>, \<^emph>\<open>OCaml\<close> and \<^emph>\<open>Scala\<close> the file specification refers to a single
-  file; for \<^emph>\<open>Haskell\<close>, it refers to a whole directory, where code is
-  generated in multiple files reflecting the module hierarchy.
-  Passing an empty file specification denotes standard output.
+  Generated code is output as logical files within the theory context, as well
+  as session exports that can be retrieved using @{tool_ref export} (or @{tool
+  build} with option \<^verbatim>\<open>-e\<close> and suitable \isakeyword{export\_files}
+  specifications in the session \<^verbatim>\<open>ROOT\<close> entry). All files have a directory
+  prefix \<^verbatim>\<open>code\<close> plus an extra file prefix that may be given via
+  \<^theory_text>\<open>file_prefix\<close> --- the default is a numbered prefix \<^verbatim>\<open>export\<close>\<open>N\<close>.
 
   Serializers take an optional list of arguments in parentheses.
 
--- a/src/HOL/Code_Numeral.thy	Thu Mar 28 21:22:44 2019 +0100
+++ b/src/HOL/Code_Numeral.thy	Thu Mar 28 21:24:55 2019 +0100
@@ -766,7 +766,7 @@
 code_identifier
   code_module Code_Numeral \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith
 
-export_code divmod_integer in Haskell
+export_code divmod_integer in Haskell file_prefix divmod
 
 
 subsection \<open>Type of target language naturals\<close>
--- a/src/HOL/Quotient_Examples/Lift_DList.thy	Thu Mar 28 21:22:44 2019 +0100
+++ b/src/HOL/Quotient_Examples/Lift_DList.thy	Thu Mar 28 21:24:55 2019 +0100
@@ -50,5 +50,6 @@
 text \<open>We can export code:\<close>
 
 export_code empty insert remove map filter null member length fold foldr concat in SML
+  file_prefix dlist
 
 end
--- a/src/HOL/Quotient_Examples/Lift_FSet.thy	Thu Mar 28 21:22:44 2019 +0100
+++ b/src/HOL/Quotient_Examples/Lift_FSet.thy	Thu Mar 28 21:24:55 2019 +0100
@@ -113,7 +113,8 @@
 
 text \<open>We can export code:\<close>
 
-export_code fnil fcons fappend fmap ffilter fset fmember in SML
+export_code fnil fcons fappend fmap ffilter fset fmember in SML file_prefix fset
+
 
 subsection \<open>Using transfer with type \<open>fset\<close>\<close>
 
--- a/src/HOL/Quotient_Examples/Lift_Set.thy	Thu Mar 28 21:22:44 2019 +0100
+++ b/src/HOL/Quotient_Examples/Lift_Set.thy	Thu Mar 28 21:24:55 2019 +0100
@@ -28,6 +28,6 @@
 term "Lift_Set.insert"
 thm Lift_Set.insert_def
 
-export_code empty insert in SML
+export_code empty insert in SML file_prefix set
 
 end
--- a/src/HOL/ex/Code_Lazy_Demo.thy	Thu Mar 28 21:22:44 2019 +0100
+++ b/src/HOL/ex/Code_Lazy_Demo.thy	Thu Mar 28 21:24:55 2019 +0100
@@ -62,7 +62,7 @@
 | "lfilter P (x ### xs) = 
    (if P x then x ### lfilter P xs else lfilter P xs)"
 
-export_code lfilter in SML
+export_code lfilter in SML file_prefix lfilter
 
 value [code] "lfilter odd llist"
 
--- a/src/Pure/Pure.thy	Thu Mar 28 21:22:44 2019 +0100
+++ b/src/Pure/Pure.thy	Thu Mar 28 21:24:55 2019 +0100
@@ -140,7 +140,7 @@
             val paths = Generated_Files.export_files thy other_thys;
           in
             if not (null paths) then
-              (writeln (Export.message thy "");
+              (writeln (Export.message thy Path.current);
                writeln (cat_lines (paths |> map (fn (path, pos) =>
                 Markup.markup (Markup.entityN, Position.def_properties_of pos)
                   (quote (Path.implode path))))))
--- a/src/Pure/Thy/export.ML	Thu Mar 28 21:22:44 2019 +0100
+++ b/src/Pure/Thy/export.ML	Thu Mar 28 21:24:55 2019 +0100
@@ -10,8 +10,8 @@
   val export_params: params -> string list -> unit
   val export: theory -> Path.T -> string list -> unit
   val export_executable: theory -> Path.T -> string list -> unit
-  val markup: theory -> string -> Markup.T
-  val message: theory -> string -> string
+  val markup: theory -> Path.T -> Markup.T
+  val message: theory -> Path.T -> string
 end;
 
 structure Export: EXPORT =
@@ -47,11 +47,13 @@
 
 (* information message *)
 
-fun markup thy s =
-  let val name = (Markup.nameN, Context.theory_long_name thy ^ (if s = "" then "" else "/" ^ s))
+fun markup thy path =
+  let
+    val thy_path = Path.append (Path.basic (Context.theory_long_name thy)) path;
+    val name = (Markup.nameN, Path.implode thy_path);
   in Active.make_markup Markup.theory_exportsN {implicit = false, properties = [name]} end;
 
-fun message thy s =
-  "See " ^ Markup.markup (markup thy s) "theory exports";
+fun message thy path =
+  "See " ^ Markup.markup (markup thy path) "theory exports";
 
 end;
--- a/src/Tools/Code/code_target.ML	Thu Mar 28 21:22:44 2019 +0100
+++ b/src/Tools/Code/code_target.ML	Thu Mar 28 21:24:55 2019 +0100
@@ -11,7 +11,7 @@
 
   datatype pretty_modules = Singleton of string * Pretty.T | Hierarchy of (string list * Pretty.T) list;
 
-  val export_code_for: Path.T option option -> string -> string -> int option -> Token.T list
+  val export_code_for: ({physical: bool} * Path.T) option -> string -> string -> int option -> Token.T list
     -> Code_Thingol.program -> bool -> Code_Symbol.T list -> local_theory -> local_theory
   val produce_code_for: Proof.context -> string -> string -> int option -> Token.T list
     -> Code_Thingol.program -> bool -> Code_Symbol.T list -> (string list * string) list * string option list
@@ -21,10 +21,10 @@
     -> Code_Thingol.program -> bool -> Code_Symbol.T list -> local_theory -> local_theory
 
   val export_code: bool -> string list
-    -> (((string * string) * Path.T option option) * Token.T list) list
+    -> (((string * string) * ({physical: bool} * Path.T) option) * Token.T list) list
     -> local_theory -> local_theory
   val export_code_cmd: bool -> string list
-    -> (((string * string) * (string * Position.T) option) * Token.T list) list
+    -> (((string * string) * ({physical: bool} * (string * Position.T)) option) * Token.T list) list
     -> local_theory -> local_theory
   val produce_code: Proof.context -> bool -> string list
     -> string -> string -> int option -> Token.T list -> (string list * string) list * string option list
@@ -33,6 +33,7 @@
   val check_code: bool -> string list -> ((string * bool) * Token.T list) list
     -> local_theory -> local_theory
 
+  val codeN: string
   val generatedN: string
   val compilation_text: Proof.context -> string -> Code_Thingol.program
     -> Code_Symbol.T list -> bool -> ((string * class list) list * Code_Thingol.itype) * Code_Thingol.iterm
@@ -148,7 +149,7 @@
   end;
 
 
-(** serializers **)
+(** theory data **)
 
 datatype pretty_modules = Singleton of string * Pretty.T | Hierarchy of (string list * Pretty.T) list;
 
@@ -166,65 +167,6 @@
   -> Code_Symbol.T list
   -> pretty_modules * (Code_Symbol.T -> string option);
 
-val generatedN = "Generated_Code";
-
-local
-
-fun flat_modules format pretty_modules =
-  (case pretty_modules of
-    Singleton (_, p) => format p
-  | Hierarchy code_modules => space_implode "\n\n" (map (format o #2) code_modules));
-
-fun export_to_file root format pretty_modules =
-  (case pretty_modules of
-    Singleton (_, p) => File.write root (format p)
-  | Hierarchy code_modules =>
-      (Isabelle_System.mkdirs root;
-        List.app (fn (names, p) =>
-          File.write (Path.appends (root :: map Path.basic names)) (format p)) code_modules));
-
-fun export_to_exports format pretty_modules =
-  let
-    fun export name content thy = (Export.export thy name [content]; thy);
-  in
-    (case pretty_modules of
-      Singleton (ext, p) => export (Path.basic (generatedN ^ "." ^ ext)) (format p)
-    | Hierarchy modules => fold (fn (names, p) => export (Path.make names) (format p)) modules)
-  end;
-
-in
-
-fun export_result some_file format (pretty_code, _) thy =
-  (case some_file of
-    NONE =>
-      let
-        val thy' = export_to_exports format pretty_code thy;
-        val _ = writeln (Export.message thy' "");
-      in thy' end
-  | SOME NONE => (writeln (flat_modules format pretty_code); thy)
-  | SOME (SOME relative_root) =>
-      let
-        val root = File.full_path (Resources.master_directory thy) relative_root;
-        val _ = File.check_dir (Path.dir root);
-        val _ = export_to_file root format pretty_code;
-      in thy end);
-
-fun produce_result syms width pretty_modules =
-  let val format = Code_Printer.format [] width in
-    (case pretty_modules of
-      (Singleton (_, p), deresolve) => ([([], format p)], map deresolve syms)
-    | (Hierarchy code_modules, deresolve) =>
-        ((map o apsnd) format code_modules, map deresolve syms))
-  end;
-
-fun present_result selects width (pretty_code, _) =
-  flat_modules (Code_Printer.format selects width) pretty_code;
-
-end;
-
-
-(** theory data **)
-
 type language = {serializer: serializer, literals: literals,
   check: {env_var: string, make_destination: Path.T -> Path.T, make_command: string -> string},
   evaluation_args: Token.T list};
@@ -237,26 +179,33 @@
 
 structure Targets = Theory_Data
 (
-  type T = (target * Code_Printer.data) Symtab.table;
-  val empty = Symtab.empty;
-  val extend = I;
-  fun merge (targets1, targets2) : T =
-    Symtab.join (fn target_name => fn ((target1, data1), (target2, data2)) =>
-      if #serial target1 = #serial target2 then
-      ({serial = #serial target1, language = #language target1,
-        ancestry = merge_ancestry (#ancestry target1, #ancestry target2)},
-        Code_Printer.merge_data (data1, data2))
-      else error ("Incompatible targets: " ^ quote target_name)
-    ) (targets1, targets2)
+  type T = (target * Code_Printer.data) Symtab.table * int;
+  val empty = (Symtab.empty, 0);
+  fun extend (targets, _) = (targets, 0);
+  fun merge ((targets1, _), (targets2, _)) : T =
+    let val targets' =
+      Symtab.join (fn target_name => fn ((target1, data1), (target2, data2)) =>
+        if #serial target1 = #serial target2 then
+        ({serial = #serial target1, language = #language target1,
+          ancestry = merge_ancestry (#ancestry target1, #ancestry target2)},
+          Code_Printer.merge_data (data1, data2))
+        else error ("Incompatible targets: " ^ quote target_name)) (targets1, targets2)
+    in (targets', 0) end;
 );
 
-fun exists_target thy = Symtab.defined (Targets.get thy);
-fun lookup_target_data thy = Symtab.lookup (Targets.get thy);
+val exists_target = Symtab.defined o #1 o Targets.get;
+val lookup_target_data = Symtab.lookup o #1 o Targets.get;
 fun assert_target thy target_name =
   if exists_target thy target_name
   then target_name
   else error ("Unknown code target language: " ^ quote target_name);
 
+fun next_export thy =
+  let
+    val thy' = (Targets.map o apsnd) (fn i => i + 1) thy;
+    val i = #2 (Targets.get thy');
+  in ("export" ^ string_of_int i, thy') end;
+
 fun fold1 f xs = fold f (tl xs) (hd xs);
 
 fun join_ancestry thy target_name =
@@ -278,7 +227,7 @@
       else ();
   in
     thy
-    |> (Targets.map o Symtab.update) (target_name, (target, Code_Printer.empty_data))
+    |> (Targets.map o apfst o Symtab.update) (target_name, (target, Code_Printer.empty_data))
   end;
 
 fun add_language (target_name, language) =
@@ -309,7 +258,7 @@
     val _ = assert_target thy target_name;
   in
     thy
-    |> (Targets.map o Symtab.map_entry target_name o apsnd o Code_Printer.map_data) f
+    |> (Targets.map o apfst o Symtab.map_entry target_name o apsnd o Code_Printer.map_data) f
   end;
 
 fun map_reserved target_name = map_data target_name o @{apply 3(1)};
@@ -317,6 +266,71 @@
 fun map_printings target_name = map_data target_name o @{apply 3(3)};
 
 
+(** serializers **)
+
+val codeN = "code";
+val generatedN = "Generated_Code";
+
+local
+
+fun export_logical file_prefix format pretty_modules =
+  let
+    val prefix = Path.append (Path.basic codeN) file_prefix;
+    fun export name content thy =
+      let
+        val path = Path.append prefix name;
+        val thy' = thy |> Generated_Files.add_files ((path, Position.none), content);
+        val _ = Export.export thy' path [content];
+      in thy' end;
+  in
+    (case pretty_modules of
+      Singleton (ext, p) => export (Path.basic (generatedN ^ "." ^ ext)) (format p)
+    | Hierarchy modules => fold (fn (names, p) => export (Path.make names) (format p)) modules)
+    #> tap (fn thy => writeln (Export.message thy prefix))
+  end;
+
+fun export_physical root format pretty_modules =
+  (case pretty_modules of
+    Singleton (_, p) => File.write root (format p)
+  | Hierarchy code_modules =>
+      (Isabelle_System.mkdirs root;
+        List.app (fn (names, p) =>
+          File.write (Path.appends (root :: map Path.basic names)) (format p)) code_modules));
+
+in
+
+fun export_result some_file format (pretty_code, _) thy =
+  (case some_file of
+    NONE =>
+      let val (file_prefix, thy') = next_export thy;
+      in export_logical (Path.basic file_prefix) format pretty_code thy' end
+  | SOME ({physical = false}, file_prefix) =>
+      export_logical file_prefix format pretty_code thy
+  | SOME ({physical = true}, file) =>
+      let
+        val root = File.full_path (Resources.master_directory thy) file;
+        val _ = File.check_dir (Path.dir root);
+        val _ = export_physical root format pretty_code;
+      in thy end);
+
+fun produce_result syms width pretty_modules =
+  let val format = Code_Printer.format [] width in
+    (case pretty_modules of
+      (Singleton (_, p), deresolve) => ([([], format p)], map deresolve syms)
+    | (Hierarchy code_modules, deresolve) =>
+        ((map o apsnd) format code_modules, map deresolve syms))
+  end;
+
+fun present_result selects width (pretty_modules, _) =
+  let val format = Code_Printer.format selects width in
+    (case pretty_modules of
+      Singleton (_, p) => format p
+    | Hierarchy code_modules => space_implode "\n\n" (map (format o #2) code_modules))
+  end;
+
+end;
+
+
 (** serializer usage **)
 
 (* technical aside: pretty printing width *)
@@ -434,7 +448,7 @@
         val destination = make_destination p;
         val lthy' = lthy
           |> Local_Theory.background_theory
-            (export_result (SOME (SOME destination)) format
+            (export_result (SOME ({physical = true}, destination)) format
               (invoke_serializer lthy target_name generatedN args program all_public syms));
         val cmd = make_command generatedN;
         val context_cmd = "cd " ^ File.bash_path p ^ " && " ^ cmd ^ " 2>&1";
@@ -488,14 +502,23 @@
 
 (* code generation *)
 
-fun prep_destination (s, pos) =
-  if s = "" then NONE
+fun prep_destination (location, (s, pos)) =
+  if location = {physical = false} then
+    (location, Path.explode s handle ERROR msg => error (msg ^ Position.here pos))
   else
     let
+      val _ =
+        if s = ""
+        then error ("Bad bad empty " ^ Markup.markup Markup.keyword2 "file" ^ " argument")
+        else ();
+      val _ =
+        legacy_feature
+          (Markup.markup Markup.keyword1 "export_code" ^ " with " ^
+            Markup.markup Markup.keyword2 "file" ^ " argument" ^ Position.here pos);
       val _ = Position.report pos Markup.language_path;
       val path = Path.explode s;
       val _ = Position.report pos (Markup.path (Path.smart_implode path));
-    in SOME path end;
+    in (location, path) end;
 
 fun export_code all_public cs seris lthy =
   let
@@ -671,7 +694,9 @@
 fun code_expr_inP (all_public, raw_cs) =
   Scan.repeat (\<^keyword>\<open>in\<close> |-- Parse.!!! (Parse.name
     -- Scan.optional (\<^keyword>\<open>module_name\<close> |-- Parse.name) ""
-    -- Scan.option (\<^keyword>\<open>file\<close> |-- Parse.position Parse.path)
+    -- Scan.option
+        ((\<^keyword>\<open>file_prefix\<close> >> K {physical = false} || \<^keyword>\<open>file\<close> >> K {physical = true})
+          -- Parse.!!! (Parse.position Parse.path))
     -- code_expr_argsP))
       >> (fn seri_args => export_code_cmd all_public raw_cs seri_args);
 
--- a/src/Tools/Code_Generator.thy	Thu Mar 28 21:22:44 2019 +0100
+++ b/src/Tools/Code_Generator.thy	Thu Mar 28 21:24:55 2019 +0100
@@ -11,7 +11,7 @@
   "export_code" "code_identifier" "code_printing" "code_reserved"
     "code_monad" "code_reflect" :: thy_decl and
   "checking" and
-  "datatypes" "functions" "module_name" "file"
+  "datatypes" "functions" "module_name" "file" "file_prefix"
     "constant" "type_constructor" "type_class" "class_relation" "class_instance" "code_module"
     :: quasi_command
 begin