Allow Catala files with a .md suffix (#916)

Author: denismerigoux

build_system/clerk_cli.ml

@@ -372,6 +372,7 @@ let init
     color
     debug
     whole_program =
+  if debug then Printexc.record_backtrace true;
   let _options = Catala_utils.Global.enforce_options ~debug ~color () in
   let default_config_file = "clerk.toml" in
   let set_root_dir dir =

build_system/clerk_driver.ml

@@ -191,7 +191,7 @@ let linking_command ~build_dir ~backend ~var_bindings link_deps item target =
         (link_deps item)
     @ [
         target -.- "cmx";
-        Filename.remove_extension target ^ "+main.cmx";
+        File.remove_extension target ^ "+main.cmx";
         "-o";
         target -.- "exe";
       ]
@@ -205,7 +205,7 @@ let linking_command ~build_dir ~backend ~var_bindings link_deps item target =
           (build_dir / dirname f / "c" / basename f) ^ ".o")
         (link_deps item)
     @ ["-lgmp"]
-    @ [target -.- "o"; Filename.remove_extension target ^ "+main.o"]
+    @ [target -.- "o"; File.remove_extension target ^ "+main.o"]
     @ get_var var_bindings Var.c_flags
     @ get_var var_bindings Var.c_include
     @ ["-o"; target -.- "exe"]
@@ -242,7 +242,7 @@ let linking_command ~build_dir ~backend ~var_bindings link_deps item target =
       (* 'javac' generates one file per inner class. Sadly, we do generate a lot
          of those. We need to pack those in the jar as well. *)
       let fetch_inner_classes class_file =
-        let basename = Filename.(basename class_file |> chop_extension) in
+        let basename = File.(remove_extension (basename class_file)) in
         let dirname = Filename.dirname class_file in
         let dir_classes =
           Hashtbl.find_opt h dirname
@@ -346,7 +346,7 @@ let string_of_backend = function
 
 let make_target ~build_dir ~backend item =
   let open File in
-  let f = Scan.target_file_name item ^ Filename.extension item.Scan.file_name in
+  let f = Scan.target_file_name item -.- File.extension item.Scan.file_name in
   let dir = dirname f in
   let base = basename f in
   let base =
@@ -489,8 +489,8 @@ let build_clerk_target
         (fun acc ((item, tg, backend), _) ->
           let targets =
             let f =
-              Scan.target_file_name item
-              ^ Filename.extension item.Scan.file_name
+              File.(
+                Scan.target_file_name item -.- extension item.Scan.file_name)
             in
             let tf =
               File.(build_dir / dirname f / backend_subdir backend / basename f)
@@ -724,7 +724,7 @@ let build_direct_targets
             let t = make_target ~build_dir ~backend item in
             match backend with
             | `Java | `Python | `Custom _ -> t
-            | _ -> Filename.remove_extension t ^ "+main" ^ Filename.extension t)
+            | _ -> File.((remove_extension t ^ "+main") -.- File.extension t))
           exec_targets
       in
       let final_ninja_targets =
@@ -880,7 +880,7 @@ let run_artifact config ~backend ~var_bindings ?scope src =
   | `Python ->
     let build_dir = config.Cli.options.global.build_dir in
     let cmd =
-      let base = Filename.(basename (remove_extension src)) in
+      let base = Filename.basename (File.remove_extension src) in
       get_var var_bindings Var.python @ ["-m"; base ^ "." ^ base]
     in
     let pythonpath =
@@ -895,7 +895,7 @@ let run_artifact config ~backend ~var_bindings ?scope src =
       (String.concat " " cmd);
     run_command ~setenv:["PYTHONPATH", pythonpath] cmd
   | `Java ->
-    let target_main = Filename.basename src |> Filename.chop_extension in
+    let target_main = File.remove_extension (Filename.basename src) in
     let cmd =
       get_var var_bindings Var.java @ ["-cp"; src -.- "jar"; target_main]
     in
@@ -923,7 +923,7 @@ let build_test_deps ~config ~backend files_or_folders nin_ppf items var_bindings
             Option.map Mark.remove item.Scan.module_def
             = Some (File.basename file)
             || item.Scan.file_name = file
-            || Filename.remove_extension item.Scan.file_name = file
+            || File.remove_extension item.Scan.file_name = file
         in
         let items = List.filter filter items in
         if items = [] then
@@ -955,10 +955,7 @@ let build_test_deps ~config ~backend files_or_folders nin_ppf items var_bindings
               @@ String.Set.add
                    (match backend with
                    | `Java | `Python -> t
-                   | _ ->
-                     Filename.remove_extension t
-                     ^ "+main"
-                     ^ Filename.extension t)
+                   | _ -> File.(remove_extension t ^ ("+main" -.- extension t)))
                    acc
           in
           List.fold_left
@@ -1463,34 +1460,30 @@ let main_cmd =
     ]
 
 let main () =
+  let[@inline] exit_with_error excode emit =
+    let bt = Printexc.get_raw_backtrace () in
+    emit ();
+    if Global.options.debug then Printexc.print_raw_backtrace stderr bt;
+    exit excode
+  in
   Sys.catch_break true;
   try exit (Cmdliner.Cmd.eval' ~catch:false main_cmd) with
   | Catala_utils.Cli.Exit_with n -> exit n
   | Message.CompilerError content ->
-    let bt = Printexc.get_raw_backtrace () in
-    Message.Content.emit content Error;
-    if Catala_utils.Global.options.debug then
-      Printexc.print_raw_backtrace stderr bt;
-    exit Cmd.Exit.some_error
+    exit_with_error Cmd.Exit.some_error
+    @@ fun () -> Message.Content.emit content Error
   | Message.CompilerErrors contents ->
-    Message.Content.emit_n contents Error;
-    exit Cmd.Exit.some_error
+    exit_with_error Cmd.Exit.some_error
+    @@ fun () -> Message.Content.emit_n contents Error
   | Sys.Break ->
-    let bt = Printexc.get_raw_backtrace () in
     Format.fprintf (Message.err_ppf ()) "@.- Interrupted -@.";
-    if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
-    exit 130
+    exit_with_error 130 (fun () -> ())
   | Sys_error msg ->
-    let bt = Printexc.get_raw_backtrace () in
-    Message.Content.emit
-      (Message.Content.of_string ("System error: " ^ msg))
-      Error;
-    if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
-    exit Cmd.Exit.internal_error
+    exit_with_error Cmd.Exit.internal_error
+    @@ fun () ->
+    Message.Content.(emit (of_string ("System error: " ^ msg)) Error)
   | e ->
-    let bt = Printexc.get_raw_backtrace () in
-    Message.Content.emit
-      (Message.Content.of_string ("Unexpected error: " ^ Printexc.to_string e))
-      Error;
-    if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
-    exit Cmd.Exit.internal_error
+    exit_with_error Cmd.Exit.internal_error
+    @@ fun () ->
+    Message.Content.(
+      emit (of_string ("Unexpected error: " ^ Printexc.to_string e)) Error)

build_system/clerk_scan.ml

@@ -28,7 +28,9 @@ type item = {
 }
 
 let catala_suffix_regex =
-  Re.(compile (seq [str ".catala_"; group (seq [alpha; alpha]); eos]))
+  Re.(
+    compile
+      (seq [str ".catala_"; group (seq [alpha; alpha]); opt (str ".md"); eos]))
 
 let test_command_args =
   let open Re in
@@ -111,7 +113,13 @@ let catala_file (file : File.t) (lang : Catala_utils.Global.backend_lang) : item
       ((* If there are includes, they must be checked for test scopes as well *)
        Lazy.force item.has_scope_tests
       || List.exists
-           (fun l -> find_test_scope ~lang (Mark.remove l))
+           (fun l ->
+             let included_file = Mark.remove l in
+             if File.check_file included_file = None then
+               Message.error ~kind:Parsing ~pos:(Mark.get l)
+                 "Included file '%s' is not a regular file or does not exist."
+                 included_file;
+             find_test_scope ~lang included_file)
            item.included_files)
   in
   { item with has_scope_tests }
@@ -132,4 +140,4 @@ let target_file_name t =
   in
   match t.module_def with
   | Some m -> dir / String.to_id (Mark.remove m)
-  | None -> dir / String.to_id (basename t.file_name -.- "")
+  | None -> dir / String.to_id (remove_extension (basename t.file_name))

compiler/catala_utils/cli.ml

@@ -43,10 +43,18 @@ let raw_file =
 
 (* Some helpers for catala sources *)
 
-let extensions = [".catala_fr", Fr; ".catala_en", En; ".catala_pl", Pl]
+let extensions =
+  [
+    "catala_fr", Fr;
+    "catala_fr.md", Fr;
+    "catala_en", En;
+    "catala_en.md", En;
+    "catala_pl", Pl;
+    "catala_pl.md", Pl;
+  ]
 
 let file_lang filename =
-  List.assoc_opt (Filename.extension filename) extensions
+  List.assoc_opt (File.extension filename) extensions
   |> function
   | Some lang -> lang
   | None -> (
@@ -152,8 +160,7 @@ module Flags = struct
         conv ~docv:"FILE"
           ( (fun s ->
               if s = "-" then Ok `Stdout
-              else if
-                Filename.extension s |> String.starts_with ~prefix:".catala"
+              else if File.extension s |> String.starts_with ~prefix:"catala"
               then
                 Error (`Msg "Output trace file cannot have a .catala extension")
               else Ok (`FileName (Global.raw_file s))),

compiler/catala_utils/file.ml

@@ -212,9 +212,34 @@ let with_formatter_of_opt_file filename_opt f =
   | None -> finally (fun () -> flush stdout) (fun () -> f Format.std_formatter)
   | Some filename -> with_formatter_of_file filename f
 
+let extension filename =
+  let file_ext = Filename.extension filename in
+  let full_extension =
+    if file_ext = ".md" then
+      let sub_ext = Filename.extension (Filename.remove_extension filename) in
+      if sub_ext = "" then "md" else sub_ext ^ ".md"
+    else file_ext
+  in
+  String.remove_prefix ~prefix:"." full_extension
+
 let ( -.- ) file ext =
-  let base = Filename.remove_extension file in
-  match ext with "" -> base | ext -> base ^ "." ^ ext
+  (* file_ext may be empty, "<ext>" when non-md, "md" if only ".md" is present
+     and "<ext>.md" if a double-extension is present *)
+  let file_ext = extension file in
+  if ext = "" then
+    (* No extension given *)
+    if file_ext = "" then (* Nothing to do *) file
+    else
+      (* Remove the extension and the dot *)
+      String.(sub file 0 (length file - length file_ext - 1))
+  else if file_ext = "" then
+    (* File has no extension, append the new one *)
+    file ^ "." ^ ext
+  else
+    (* Remove the existing extension (minus the dot) and append the new one *)
+    String.(sub file 0 (length file - length file_ext)) ^ ext
+
+let remove_extension filename = filename -.- ""
 
 let get_main_out_channel ~source_file ~output_file ?ext () =
   match output_file, ext with
@@ -241,7 +266,7 @@ let with_secondary_out_channel ~output_file ~ext f =
     let file =
       match ext.[0] with
       | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' -> file -.- ext
-      | _ -> Filename.remove_extension file ^ ext
+      | _ -> remove_extension file ^ ext
     in
     Message.debug "Secondary output to %a" format file;
     with_formatter_of_file file (fun ppf -> f (Some file) ppf)
@@ -424,7 +449,6 @@ let check_exec t =
 
 let dirname = Filename.dirname
 let basename = Filename.basename
-let extension t = String.remove_prefix ~prefix:"." (Filename.extension t)
 let ( /../ ) a b = parent a / b
 
 let equal a b =

compiler/catala_utils/file.mli

@@ -148,7 +148,9 @@ val dirname : t -> t
 
 val extension : t -> string
 (** Like [Filename.extension], but without the leading dot (doesn't, therefore,
-    differenciate between empty extension and no extension) *)
+    differenciate between empty extension and no extension). It also considers
+    catala + md extensions as a single extension, hence
+    [extension "a_file.catala_en.md"] will return ["catala_en.md"] *)
 
 val parent : t -> t
 (** Similar to [dirname], except it strips the last **non-"." or ".."** element
@@ -199,6 +201,9 @@ val ( -.- ) : t -> string -> t
     with the given one (which shouldn't start with a dot). No dot is appended if
     the provided extension is empty. *)
 
+val remove_extension : t -> string
+(** [remove_extension filename] is equivalent to [filename -.- ""] *)
+
 val path_to_list : t -> string list
 (** Empty elements or current-directory (".") are skipped in the resulting list *)
 

compiler/catala_utils/pos.ml

@@ -154,7 +154,12 @@ let to_string_short (pos : t) : string =
 
 let to_string_shorter (pos : t) : string =
   let s, e = pos.code_pos in
-  let f = Filename.(remove_extension (basename s.Lexing.pos_fname)) in
+  let f =
+    if Filename.extension s.Lexing.pos_fname = ".md" then
+      Filename.(
+        remove_extension (remove_extension (basename s.Lexing.pos_fname)))
+    else Filename.(remove_extension (basename s.Lexing.pos_fname))
+  in
   if s.Lexing.pos_lnum = e.Lexing.pos_lnum then
     Printf.sprintf "%s:%d.%d-%d" f s.Lexing.pos_lnum
       (s.Lexing.pos_cnum - s.Lexing.pos_bol + 1)

compiler/driver.ml

@@ -20,7 +20,15 @@ open Shared_ast
 
 (** Associates a file extension with its corresponding
     {!type: Global.backend_lang} string representation. *)
-let extensions = [".catala_fr", "fr"; ".catala_en", "en"; ".catala_pl", "pl"]
+let extensions =
+  [
+    ".catala_fr", "fr";
+    ".catala_fr.md", "fr";
+    ".catala_en", "en";
+    ".catala_en.md", "en";
+    ".catala_pl", "pl";
+    ".catala_pl.md", "pl";
+  ]
 
 let load_modules
     options
@@ -122,7 +130,7 @@ let load_modules
               (* This preserves the filename capitalisation, which corresponds
                  to the convention for files related to not-module compilation
                  artifacts and is used by [depends] below *)
-              Some Filename.(basename (remove_extension f))
+              Some (Filename.basename (File.remove_extension f))
             else None
           in
           let module_content =
@@ -544,7 +552,7 @@ module Commands = struct
       (String.concat "\\\n"
          (Option.value ~default:"stdout" output_file
          :: List.map
-              (fun ext -> Filename.remove_extension source_file ^ ext)
+              (fun ext -> File.remove_extension source_file ^ ext)
               backend_extensions_list))
       (String.concat "\\\n" prg.Surface.Ast.program_source_files)
       (String.concat "\\\n" prg.Surface.Ast.program_source_files)
@@ -1248,9 +1256,9 @@ module Commands = struct
       match output_file, options.Global.input_src with
       | Some file, _
       | None, (FileName (file : File.t) | Contents (_, (file : File.t))) ->
-        let name = Filename.(remove_extension file |> basename) in
+        let name = File.remove_extension file |> Filename.basename in
         if Global.options.gen_external then
-          String.capitalize_ascii (Filename.remove_extension name)
+          String.capitalize_ascii (File.remove_extension name)
         else name
       | None, Stdin _ -> "AnonymousClass"
     in
@@ -1314,7 +1322,7 @@ module Commands = struct
               (fun f ->
                 let name =
                   String.capitalize_ascii
-                    (String.to_id Filename.(basename (remove_extension f)))
+                    (String.to_id (Filename.basename (File.remove_extension f)))
                 in
                 {
                   mod_use_name = name, Pos.void;

compiler/lcalc/to_ocaml.ml

@@ -712,9 +712,7 @@ let commands = if commands = [] then test_scopes else commands
   let modname =
     match p.module_name with
     | Some (n, _) -> ModuleName.to_string n
-    | None ->
-      String.capitalize_ascii
-        (File.basename (Filename.remove_extension filename))
+    | None -> String.capitalize_ascii File.(basename filename -.- "")
   in
   Format.pp_open_vbox fmt 0;
   Format.fprintf fmt "open Catala_runtime@,";

compiler/literate/pygmentize.ml

@@ -40,7 +40,7 @@ let exec () =
     | None ->
       List.find_map
         (fun s ->
-          match Filename.extension s with
+          match File.extension s with
           | "" -> None
           | e -> lang_of_ext (String.sub e 1 (String.length e - 1)))
         args