Rehaul the Clerk build system to fully handle modules and linking

build_system/clerk_runtest.ml

@@ -205,7 +205,9 @@ let run_inline_tests
             else catala_exe
           in
           let cmd =
-            Array.of_list ((catala_exe :: catala_opts) @ test.params @ [file])
+            match test.params with
+            | cmd0 :: flags -> Array.of_list (catala_exe :: cmd0 :: catala_opts @ flags @ [file])
+            | [] -> Array.of_list (catala_exe :: catala_opts @ [file])
           in
           let env =
             Unix.environment ()

build_system/ninja_utils.ml

@@ -14,18 +14,41 @@
    License for the specific language governing permissions and limitations under
    the License. *)
 
+(** Ninja variable names *)
+module Var = struct
+  type t = V of string
+
+  let make s = V s
+
+  let name (V v) = v
+
+  let v (V v) = Printf.sprintf "${%s}" v
+
+end
+
 module Expr = struct
-  type t = Lit of string | Var of string | Seq of t list
+  type t = string list
 
-  let rec format fmt = function
-    | Lit s -> Format.pp_print_string fmt s
-    | Var s -> Format.fprintf fmt "$%s" s
-    | Seq ls -> format_list fmt ls
-
-  and format_list fmt ls =
+  let format =
     Format.pp_print_list
       ~pp_sep:(fun fmt () -> Format.pp_print_char fmt ' ')
-      format fmt ls
+      (fun fmt s ->
+         Format.pp_print_string fmt
+           (Re.replace_string Re.(compile space) ~by:"$ " s))
+end
+
+module Binding = struct
+  type t = Var.t * Expr.t
+  let make var e = var, e
+  let format ~global ppf (v, e) =
+    if not global then Format.pp_print_string ppf "  ";
+    Format.fprintf ppf "%s = %a"
+      (Var.name v)
+      Expr.format e;
+    if global then Format.pp_print_newline ppf ()
+
+  let format_list ~global ppf l =
+    Format.pp_print_list ~pp_sep:Format.pp_print_newline (format ~global) ppf l
 end
 
 module Rule = struct
@@ -35,62 +58,78 @@ module Rule = struct
     { name; command; description = Option.some description }
 
   let format fmt rule =
-    let format_description fmt = function
-      | Some e -> Format.fprintf fmt "  description = %a\n" Expr.format e
-      | None -> Format.fprintf fmt "\n"
+    let bindings =
+      Binding.make (Var.make "command") rule.command ::
+      Option.(to_list (map (fun d -> Binding.make (Var.make "description") d) rule.description))
     in
-    Format.fprintf fmt "rule %s\n  command = %a\n%a" rule.name Expr.format
-      rule.command format_description rule.description
+    Format.fprintf fmt "rule %s\n%a"
+      rule.name (Binding.format_list ~global:false) bindings
 end
 
 module Build = struct
   type t = {
-    outputs : Expr.t list;
     rule : string;
-    inputs : Expr.t list option;
-    vars : (string * Expr.t) list;
+    inputs : Expr.t option;
+    implicit_in : Expr.t;
+    outputs : Expr.t;
+    implicit_out : Expr.t option;
+    vars : Binding.t list;
   }
 
-  let make ~outputs ~rule = { outputs; rule; inputs = Option.none; vars = [] }
+  let make ?inputs ?(implicit_in=[]) ~outputs ?implicit_out ?(vars=[]) rule =
+    { rule; inputs; implicit_in; outputs; implicit_out; vars }
 
-  let make_with_vars ~outputs ~rule ~vars =
-    { outputs; rule; inputs = Option.none; vars }
-
-  let make_with_inputs ~outputs ~rule ~inputs =
-    { outputs; rule; inputs = Option.some inputs; vars = [] }
-
-  let make_with_vars_and_inputs ~outputs ~rule ~inputs ~vars =
-    { outputs; rule; inputs = Option.some inputs; vars }
-
-  let empty = make ~outputs:[Expr.Lit "empty"] ~rule:"phony"
+  let empty = make ~outputs:["empty"] "phony"
 
   let unpath ?(sep = "-") path =
     Re.Pcre.(substitute ~rex:(regexp "/") ~subst:(fun _ -> sep)) path
 
-  let format fmt build =
-    let format_inputs fmt = function
-      | Some exs -> Format.fprintf fmt " %a" Expr.format_list exs
-      | None -> ()
-    and format_vars fmt vars =
-      List.iter
-        (fun (name, exp) ->
-          Format.fprintf fmt "  %s = %a\n" name Expr.format exp)
-        vars
-    in
-    Format.fprintf fmt "build %a: %s%a\n%a" Expr.format_list build.outputs
-      build.rule format_inputs build.inputs format_vars build.vars
+  let format fmt t =
+    Format.fprintf fmt "build %a%a: %s%a%a%a%a"
+      Expr.format t.outputs
+      (Format.pp_print_option
+         (fun fmt i ->
+            Format.pp_print_string fmt " | ";
+            Expr.format fmt i))
+      t.implicit_out
+      t.rule
+      (Format.pp_print_option
+         (fun ppf e -> Format.pp_print_char ppf ' '; Expr.format ppf e))
+      t.inputs
+      (fun ppf -> function [] -> () | e -> Format.pp_print_string ppf " | "; Expr.format ppf e)
+      t.implicit_in
+      (if t.vars = [] then fun _ () -> () else Format.pp_print_newline) ()
+      (Binding.format_list ~global:false)
+      t.vars
 end
 
-module RuleMap : Map.S with type key = String.t = Map.Make (String)
-module BuildMap : Map.S with type key = String.t = Map.Make (String)
+type def = Comment of string | Binding of Binding.t | Rule of Rule.t | Build of Build.t
 
-type ninja = { rules : Rule.t RuleMap.t; builds : Build.t BuildMap.t }
+let comment s = Comment s
+let binding v e = Binding (Binding.make v e)
+let rule name ~command ~description =
+  Rule (Rule.make name ~command ~description)
+let build ?inputs ?implicit_in ~outputs ?implicit_out ?vars rule =
+  Build (Build.make ?inputs ?implicit_in ~outputs ?implicit_out ?vars rule)
 
-let empty = { rules = RuleMap.empty; builds = BuildMap.empty }
 
-let format fmt ninja =
-  let format_for_all iter format =
-    iter (fun _name rule -> Format.fprintf fmt "%a\n" format rule)
+let format_def ppf def =
+  let () = match def with
+    | Comment s ->
+      Format.pp_print_list ~pp_sep:Format.pp_print_newline
+        (fun ppf s ->
+           if s <> "" then Format.pp_print_string ppf "# ";
+           Format.pp_print_string ppf s)
+        ppf
+        (String.split_on_char '\n' s)
+    | Binding b -> Binding.format ~global:true ppf b
+    | Rule r -> Rule.format ppf r; Format.pp_print_newline ppf ()
+    | Build b -> Build.format ppf b
   in
-  format_for_all RuleMap.iter Rule.format ninja.rules;
-  format_for_all BuildMap.iter Build.format ninja.builds
+  Format.pp_print_flush ppf ()
+
+type ninja = def Seq.t
+
+let format ppf t =
+  Format.pp_print_seq ~pp_sep:Format.pp_print_newline format_def ppf t;
+  Format.pp_print_newline ppf ()

build_system/ninja_utils.mli

@@ -34,31 +34,35 @@
 
 (** {1 Ninja expressions} *)
 
+(** Ninja variable names, distinguishing binding name ("x") from references in expressions ("$x") *)
+module Var : sig
+  type t
+
+  val make: string -> t
+
+  (** Var base name, used when binding it *)
+  val name: t -> string
+
+  (** Var reference with a preceding "$", for use in expressoins *)
+  val v: t -> string
+end
+
+
 (** Helper module to build ninja expressions. *)
 module Expr : sig
-  (** Represents a ninja expression. Which could be either a literal, a
-      {{:https://ninja-build.org/manual.html#_variables} variable references}
-      ($_) or a sequence of sub-expressions.
-
-      {b Note:} for now, there are no visible differences between an [Expr.Seq]
-      and a list of {!type: Expr.t}, indeed, in both cases, one space is added
-      between each expression -- resp. sub-expression. The difference only comes
-      from the semantic: an [Expr.Seq] is {b a unique} Ninja expression. *)
-  type t =
-    | Lit of string
-    (* Literal string. *)
-    | Var of string
-    (* Variable reference. *)
-    | Seq of t list
-  (* Sequence of sub-expressions. *)
+  (** Ninja expressions are represented as raw string lists, which may contain variables or "$-escapes" *)
+  type t = string list
 
   val format : Format.formatter -> t -> unit
   (** [format fmt exp] outputs in [fmt] the string representation of the ninja
-      expression [exp]. *)
+      expression [exp]. Spaces in individual elements are escaped (but no check is made for e.g. newlines) *)
 
-  val format_list : Format.formatter -> t list -> unit
-  (** [format fmt ls] outputs in [fmt] the string representation of a list [ls]
-      of ninja expressions [exp] by adding a space between each expression. *)
+end
+
+module Binding : sig
+  type t = Var.t * Expr.t
+  val make: Var.t -> Expr.t -> t
+  val format: global:bool -> Format.formatter -> t -> unit
 end
 
 (** {1 Ninja rules} *)
@@ -66,7 +70,7 @@ end
 (** Helper module to build
     {{:https://ninja-build.org/manual.html#_rules} ninja rules}. *)
 module Rule : sig
-  type t = { name : string; command : Expr.t; description : Expr.t option }
+  type t
   (** Represents the minimal ninja rule representation for Clerk:
 
       {[
@@ -89,12 +93,7 @@ end
 (** Helper module to build ninja
     {{:https://ninja-build.org/manual.html#_build_statements} build statements}. *)
 module Build : sig
-  type t = {
-    outputs : Expr.t list;
-    rule : string;
-    inputs : Expr.t list option;
-    vars : (string * Expr.t) list;
-  }
+  type t
   (** Represents the minimal ninja build statement representation for Clerk:
 
       {[
@@ -102,28 +101,15 @@ module Build : sig
           [<vars>]
       ]}*)
 
-  val make : outputs:Expr.t list -> rule:string -> t
-  (** [make ~outputs ~rule] returns the corresponding ninja {!type:Build.t} with
-      no {!field:inputs} or {!field:vars}. *)
-
-  val make_with_vars :
-    outputs:Expr.t list -> rule:string -> vars:(string * Expr.t) list -> t
-  (** [make_with_vars ~outputs ~rule ~vars] returns the corresponding ninja
-      {!type:Build.t} with no {!field:inputs}. *)
-
-  val make_with_inputs :
-    outputs:Expr.t list -> rule:string -> inputs:Expr.t list -> t
-  (** [make_with_vars ~outputs ~rule ~inputs] returns the corresponding ninja
-      {!type:Build.t} with no {!field:vars}. *)
-
-  val make_with_vars_and_inputs :
-    outputs:Expr.t list ->
-    rule:string ->
-    inputs:Expr.t list ->
-    vars:(string * Expr.t) list ->
+  val make :
+    ?inputs:Expr.t ->
+    ?implicit_in:Expr.t ->
+    outputs:Expr.t ->
+    ?implicit_out:Expr.t ->
+    ?vars:(Var.t * Expr.t) list ->
+    string ->
     t
-  (** [make_with_vars ~outputs ~rule ~inputs ~vars] returns the corresponding
-      ninja {!type: Build.t}. *)
+  (** [make ~outputs rule] returns the corresponding ninja {!type:Build.t}. *)
 
   val empty : t
   (** [empty] is the minimal ninja {!type:Build.t} with ["empty"] as
@@ -139,20 +125,22 @@ module Build : sig
       [build]. *)
 end
 
-(** {1 Maps} *)
+type def = Comment of string | Binding of Binding.t | Rule of Rule.t | Build of Build.t
 
-module RuleMap : Map.S with type key = String.t
-module BuildMap : Map.S with type key = String.t
+val comment: string -> def
+val binding: Var.t -> Expr.t -> def
+val rule: string -> command:Expr.t -> description:Expr.t -> def
+val build:
+  ?inputs:Expr.t ->
+  ?implicit_in:Expr.t ->
+  outputs:Expr.t ->
+  ?implicit_out:Expr.t ->
+  ?vars:(Var.t * Expr.t) list ->
+  string ->
+  def
 
-(** {1 Ninja} *)
+val format_def: Format.formatter -> def -> unit
 
-type ninja = { rules : Rule.t RuleMap.t; builds : Build.t BuildMap.t }
-(** Represents the minimal ninja architecture (list of rule and build
-    statements) needed for clerk. *)
+type ninja = def Seq.t
 
-val empty : ninja
-(** [empty] returns the empty empty ninja structure. *)
-
-val format : Format.formatter -> ninja -> unit
-(** [format fmt build] outputs in [fmt] the string representation of all
-    [ninja.rules] and [ninja.builds]. *)
+val format: Format.formatter -> ninja -> unit

compiler/catala_utils/cli.ml

@@ -39,6 +39,7 @@ type options = {
   mutable message_format : message_format_enum;
   mutable trace : bool;
   mutable plugins_dirs : string list;
+  mutable build_dir : string option;
   mutable disable_warnings : bool;
   mutable max_prec_digits : int;
 }
@@ -57,6 +58,7 @@ let globals =
     message_format = Human;
     trace = false;
     plugins_dirs = [];
+    build_dir = None;
     disable_warnings = false;
     max_prec_digits = 20;
   }
@@ -69,6 +71,7 @@ let enforce_globals
     ?message_format
     ?trace
     ?plugins_dirs
+    ?build_dir
     ?disable_warnings
     ?max_prec_digits
     () =
@@ -79,6 +82,7 @@ let enforce_globals
   Option.iter (fun x -> globals.message_format <- x) message_format;
   Option.iter (fun x -> globals.trace <- x) trace;
   Option.iter (fun x -> globals.plugins_dirs <- x) plugins_dirs;
+  Option.iter (fun x -> globals.build_dir <- x) build_dir;
   Option.iter (fun x -> globals.disable_warnings <- x) disable_warnings;
   Option.iter (fun x -> globals.max_prec_digits <- x) max_prec_digits;
   globals
@@ -187,6 +191,11 @@ module Flags = struct
       in
       value & opt_all string default & info ["plugin-dir"] ~docv:"DIR" ~env ~doc
 
+    let build_dir =
+      value
+      & opt (some string) None
+      & info ["build-dir"] ~docv:"DIR" ~doc:"Directory where build artefacts are expected to be found. This doesn't affect outptuts, but is used when looking up compiled modules."
+
     let disable_warnings =
       value
       & flag
@@ -210,13 +219,14 @@ module Flags = struct
           message_format
           trace
           plugins_dirs
+          build_dir
           disable_warnings
           max_prec_digits : options =
         if debug then Printexc.record_backtrace true;
         (* This sets some global refs for convenience, but most importantly
            returns the options record. *)
         enforce_globals ~language ~debug ~color ~message_format ~trace
-          ~plugins_dirs ~disable_warnings ~max_prec_digits ()
+          ~plugins_dirs ~build_dir ~disable_warnings ~max_prec_digits ()
       in
       Term.(
         const make
@@ -226,6 +236,7 @@ module Flags = struct
         $ message_format
         $ trace
         $ plugins_dirs
+        $ build_dir
         $ disable_warnings
         $ max_prec_digits)
 
@@ -319,6 +330,7 @@ module Flags = struct
           "Disables the search for counterexamples. Useful when you want a \
            deterministic output from the Catala compiler, since provers can \
            have some randomness in them."
+
 end
 
 (* Retrieve current version from dune *)

compiler/catala_utils/cli.mli

@@ -20,6 +20,8 @@ type backend_lang = En | Fr | Pl
 (** The usual auto/always/never option argument *)
 type when_enum = Auto | Always | Never
 
+val when_opt: when_enum Cmdliner.Arg.conv
+
 type message_format_enum =
   | Human
   | GNU  (** Format of error and warning messages output by the compiler. *)
@@ -41,6 +43,7 @@ type options = private {
   mutable message_format : message_format_enum;
   mutable trace : bool;
   mutable plugins_dirs : string list;
+  mutable build_dir : string option;
   mutable disable_warnings : bool;
   mutable max_prec_digits : int;
 }
@@ -60,6 +63,7 @@ val enforce_globals :
   ?message_format:message_format_enum ->
   ?trace:bool ->
   ?plugins_dirs:string list ->
+  ?build_dir:string option ->
   ?disable_warnings:bool ->
   ?max_prec_digits:int ->
   unit ->

compiler/catala_utils/file.ml

@@ -120,10 +120,17 @@ let check_directory d =
 let ( / ) = Filename.concat
 let dirname = Filename.dirname
 let ( /../ ) a b = dirname a / b
+let ( -.- ) file ext = Filename.chop_extension file ^ "." ^ ext
+
 let equal = String.equal
 let compare = String.compare
 let format ppf t = Format.fprintf ppf "\"@{<cyan>%s@}\"" t
 
+module Set = Set.Make(struct
+    type nonrec t = t
+    let compare = compare
+end)
+
 let scan_tree f t =
   let is_dir t =
     try Sys.is_directory t
@@ -136,7 +143,7 @@ let scan_tree f t =
     Sys.readdir d
     |> Array.to_list
     |> List.filter not_hidden
-    |> List.map (fun t -> d / t)
+    |> (if d = "." then fun t -> t else List.map (fun t -> d / t))
     |> do_files
   and do_files flist =
     let dirs, files =
@@ -148,4 +155,4 @@ let scan_tree f t =
       (Seq.concat (Seq.map do_dir (List.to_seq dirs)))
       (Seq.filter_map f (List.to_seq files))
   in
-  do_dir t
+  do_files [t]

compiler/catala_utils/file.mli

@@ -95,6 +95,9 @@ val dirname : t -> t
 val ( /../ ) : t -> t -> t
 (** Sugar for [Filename.dirname "a" / b] *)
 
+val ( -.- ) : t -> string -> t
+(** Extension replacement: chops the given filename extension, and replaces it with the given one (which shouldn't contain a dot) *)
+
 val equal : t -> t -> bool
 (** String comparison no fancy file resolution *)
 
@@ -105,7 +108,9 @@ val format : Format.formatter -> t -> unit
 (** Formats a filename in a consistent style, with double-quotes and color (when
     the output supports) *)
 
+module Set: Set.S with type elt = t
+
 val scan_tree : (t -> 'a option) -> t -> 'a Seq.t
 (** Recursively scans a directory for files. Directories or files matching ".*"
     or "_*" are ignored. Unreadable files or subdirectories are ignored with a
-    debug message. *)
+    debug message. If [t] is a plain file, scan just that non-recursively. *)

compiler/shared_ast/interpreter.ml

@@ -947,7 +947,7 @@ let load_runtime_modules = function
     List.iter
       Dynlink.(
         fun m ->
-          try loadfile (adapt_filename (Filename.remove_extension m ^ ".cmo"))
+          try loadfile (adapt_filename File.(match Cli.globals.build_dir with None -> m -.- "cmo" | Some d -> d / m -.- "cmo"))
           with Dynlink.Error dl_err ->
             Message.raise_error
               "Could not load module %s, has it been suitably compiled?@;\

compiler/shared_ast/interpreter.mli

@@ -74,4 +74,4 @@ val interpret_program_lcalc :
 
 val load_runtime_modules : string list -> unit
 (** Dynlink the given runtime modules, in order to make them callable by the
-    interpreter *)
+    interpreter. If Cli.globals.build_dir is specified, the runtime module names are assumed to be relative and looked up there. *)

compiler/surface/lexer.cppo.ml

@@ -820,7 +820,7 @@ let line_dir_arg_re =
 let lex_line (lexbuf : lexbuf) : (string * L.line_token) option =
   match%sedlex lexbuf with
   | eof -> None
-  | "```catala-test", Star (Compl '\n'), ('\n' | eof) ->
+  | "```catala-test", hspace, Star (Compl '\n'), ('\n' | eof) ->
     let str = Utf8.lexeme lexbuf in
     (try
        let id = Re.Group.get (Re.exec line_test_id_re str) 1 in

tests/test_modules/good/mod_def.catala_en

@@ -22,5 +22,6 @@ scope S:
 ```
 
 ```catala-test-inline
-$ catala module --compile --plugin-dir=../../../_build/default/compiler/plugins --disable_warnings
+$ catala typecheck --disable_warnings
+[RESULT] Typechecking successful!
 ```