Declare the files to load from an external configuration file

6 files changed, 283 insertions, 67 deletions

diff --git a/lib/configuration/expression_parser.mly b/lib/configuration/expression_parser.mly
index 1761cce..9b97637 100644
--- a/lib/configuration/expression_parser.mly
+++ b/lib/configuration/expression_parser.mly
@@ -34,20 +34,25 @@ column_expr:
 
 path_: 
     | COLUMN
-      column = IDENT    
-        { ImportExpression.T.Path 
-             ImportDataTypes.Path.{ alias = None
-            ; column = ImportDataTypes.Path.column_of_string column
-            }
-        }
-
-    | COLUMN
-      table = IDENT
-      DOT
-      column = IDENT    
-      { ImportExpression.T.Path
-             ImportDataTypes.Path.{ alias = Some table 
-            ; column = ImportDataTypes.Path.column_of_string column}
+      (* The dot character is required as a separator between the table and the
+         colum, like in [:table.XX] but the table name can also contains [.]
+         (this is allowed in the toml configuration syntax, as long as the
+         identifier is quoted.
+
+         So we have to handle cases like [:foo.bar.XX]
+       *)
+      path = separated_nonempty_list(DOT, IDENT)
+      { let reversed_path = List.rev path in
+        (* reversed_path is nonempty, and we can take head and tail safely *)
+        let tail =  List.tl reversed_path in
+        let alias = match tail with
+        | [] -> None
+        | tl -> Some (String.concat "." (List.rev tl))
+        in
+
+        ImportExpression.T.Path
+             ImportDataTypes.Path.{ alias
+            ; column = ImportDataTypes.Path.column_of_string (List.hd reversed_path)}
       }
 
 column_: 
diff --git a/lib/configuration/importConf.ml b/lib/configuration/importConf.ml
index 2df24bd..4b49686 100644
--- a/lib/configuration/importConf.ml
+++ b/lib/configuration/importConf.ml
@@ -1,14 +1,22 @@
 module TomlReader = Read_conf.Make (Helpers.Toml.Decode)
 
-let t_of_toml : Otoml.t -> (ImporterSyntax.t, string) result =
- fun toml ->
+type loader_context = TomlReader.loader_context = {
+  checkFile : string -> bool;
+  loadFile : string -> Otoml.t;
+}
+
+let t_of_toml :
+    context:loader_context -> Otoml.t -> (ImporterSyntax.t, string) result =
+ fun ~context toml ->
   let version =
     Otoml.find_or ~default:ImporterSyntax.latest_version toml
       (Otoml.get_integer ~strict:false)
       [ "version" ]
   in
   match version with
-  | n when n = ImporterSyntax.latest_version -> TomlReader.read toml
+  | n when n = ImporterSyntax.latest_version -> begin
+      TomlReader.read context toml
+    end
   | _ ->
       Printf.eprintf "Unsuported version : %d\n" version;
       exit 1
diff --git a/lib/configuration/importConf.mli b/lib/configuration/importConf.mli
index d2f65f2..7234499 100644
--- a/lib/configuration/importConf.mli
+++ b/lib/configuration/importConf.mli
@@ -1,4 +1,12 @@
-val t_of_toml : Otoml.t -> (ImporterSyntax.t, string) result
+type loader_context = {
+  checkFile : string -> bool;
+  loadFile : string -> Otoml.t;
+}
+
+val t_of_toml :
+  context:loader_context -> Otoml.t -> (ImporterSyntax.t, string) result
+(** [fileChecker] is called when a file is declared in the configuration. An
+    arror will be raised if the computation return false *)
 
 val expression_from_string :
   string -> (ImportDataTypes.Path.t ImportExpression.T.t, string) result
diff --git a/lib/configuration/read_conf.ml b/lib/configuration/read_conf.ml
index d406b0e..c3c78cc 100644
--- a/lib/configuration/read_conf.ml
+++ b/lib/configuration/read_conf.ml
@@ -178,14 +178,61 @@ module Make (S : Decoders.Decode.S) = struct
   let ( >>= ) = S.( >>= )
   let ( >|= ) = S.( >|= )
 
-  class loader =
+  type loader_context = {
+    checkFile : string -> bool;
+    loadFile : string -> S.value;
+  }
+
+  type dataSet = S.value * (string * string) list
+
+  class loader (context : loader_context) =
     object (self)
+      method path_checker : string S.decoder -> string S.decoder =
+        fun check ->
+          Decoders.Decoder.bind
+            (fun path ->
+              if context.checkFile path then Decoders.Decoder.pure path
+              else Decoders.Decoder.fail "Expected a path to an existing file")
+            check
+      (** Check if a file given in the configuration exists: an error is raised
+          if the function [checkFile] retun false.
+
+          In the unit tests, the effect is mapped to a function returning alway
+          true. *)
+
+      method keep : type a. a S.decoder -> (S.value * a) S.decoder =
+        fun decoder value -> S.map (fun v -> (value, v)) decoder value
+      (** [keep decoder] transform a decoder and keep the initial value with the
+          decoded value.
+
+          This helps to build custom error message, if we want to report an
+          error from a different place. *)
+
+      method load_resources : dataSet option S.decoder =
+        (* Do not accept dash in the keys, as the caracter is used to alias
+           the same file in differents mappings *)
+        let no_dash_decoder =
+          let* s = S.string in
+          match String.exists s ~f:(Char.equal '-') with
+          | true -> S.fail "Expected a key without '-'"
+          | false -> S.succeed s
+        in
+        let list_files_decoders =
+          self#keep (S.key_value_pairs' no_dash_decoder S.string)
+        in
+        let get_field = S.field "files" list_files_decoders in
+
+        let* result = S.map context.loadFile (self#path_checker S.string) in
+        let files = get_field result in
+        let dataSetResult = Result.map (fun v -> Some v) files in
+        S.from_result dataSetResult
+      (** Load an external file containing the list of files to include.*)
+
       method parse_expression : type a.
           ?groups:a ImportExpression.T.t list ->
           eq:(a -> a -> bool) ->
           a ExpressionParser.path_builder ->
-          S.value ->
-          (a ImportExpression.T.t, S.value Decoders.Error.t) result =
+          a ImportExpression.T.t S.decoder =
         fun ?(groups = []) ~eq path ->
           S.string >>= fun v ->
           match ExpressionParser.of_string path v with
@@ -202,41 +249,83 @@ module Make (S : Decoders.Decode.S) = struct
                   S.fail
                     "A group function cannot contains another group function")
 
-      method source =
-        let* file = S.field "file" S.string
-        and* name = S.field "name" S.string
-        and* tab = S.field_opt_or ~default:1 "tab" S.int in
-        S.succeed { Table.file; name; tab }
-
-      method external_ name =
-        let* intern_key =
-          S.field "intern_key"
-            (self#parse_expression ~eq:Path.equal ExpressionParser.path)
-        and* extern_key =
-          S.field "extern_key"
-            (self#parse_expression ~eq:Int.equal ExpressionParser.column)
-        and* file = S.field "file" S.string
-        and* tab = S.field_opt_or ~default:1 "tab" S.int
-        and* allow_missing =
-          S.field_opt_or ~default:false "allow_missing" S.bool
-        in
+      method look_file :
+          dataset:dataSet option -> name:string -> string S.decoder =
+        fun ~dataset ~name ->
+          self#path_checker
+            (S.one_of
+               [
+                 (* If the file is declared, use it *)
+                 ("file", S.field "file" S.string);
+                 ( "dataset",
+                   (* Otherwise search in the data set *)
+
+                   (* We work inside an option monad : 
+                       - Do we have a dataset
+                       - Do we have a valid root name to look for
+                       - De we have a match in the dataset
+                    *)
+                   let ( let* ) = Option.bind in
+                   let element =
+                     let* _, resources = dataset in
+                     let* root =
+                       match String.split_on_char ~sep:'-' name with
+                       | hd :: _ -> Some hd
+                       | _ -> None
+                     in
+                     let* elem = List.assoc_opt root resources in
+                     Some elem
+                   in
+                   match (element, dataset) with
+                   | Some value, _ -> S.succeed value
+                   | None, Some (t, _) ->
+                       let message = "Looking for \"" ^ name ^ "\"" in
+                       S.fail_with (Decoders.Error.make ~context:t message)
+                   | None, None -> S.fail "No dataset declared" );
+               ])
+
+      method source : dataSet option -> Table.t S.decoder =
+        fun dataset ->
+          (* The file shall either be present in the external, or be declared
+           in the dataset *)
+          let* name = S.field "name" S.string in
+          let* file = self#look_file ~dataset ~name
+          and* tab = S.field_opt_or ~default:1 "tab" S.int in
+          S.succeed { Table.file; Table.name; Table.tab }
 
-        S.succeed
-          ImporterSyntax.Extern.
-            {
-              intern_key;
-              extern_key;
-              target = { name; file; tab };
-              allow_missing;
-              match_rule = None;
-            }
+      method external' :
+          dataSet option -> string -> ImporterSyntax.Extern.t S.decoder =
+        fun dataset name ->
+          let* intern_key =
+            S.field "intern_key"
+              (self#parse_expression ~eq:Path.equal ExpressionParser.path)
+          and* extern_key =
+            S.field "extern_key"
+              (self#parse_expression ~eq:Int.equal ExpressionParser.column)
+          and* file = self#look_file ~dataset ~name
+          and* tab = S.field_opt_or ~default:1 "tab" S.int
+          and* allow_missing =
+            S.field_opt_or ~default:false "allow_missing" S.bool
+          in
+
+          S.succeed
+            ImporterSyntax.Extern.
+              {
+                intern_key;
+                extern_key;
+                target = { name; file; tab };
+                allow_missing;
+                match_rule = None;
+              }
+      (** Load the configuration for an external file to link *)
 
       method sheet =
         (* Check the uniq property first, beecause the group functions need
              to include the same expression (at least) *)
         let* uniq =
           S.field_opt_or ~default:[] "uniq"
-          @@ S.list (self#parse_expression ~eq:Path.equal ExpressionParser.path)
+          @@ S.list
+          @@ self#parse_expression ~eq:Path.equal ExpressionParser.path
         in
 
         let* columns =
@@ -247,23 +336,27 @@ module Make (S : Decoders.Decode.S) = struct
         and* filters =
           S.field_opt_or ~default:[] "filters"
           @@ S.list
-               (self#parse_expression ~eq:Path.equal ~groups:uniq
-                  ExpressionParser.path)
+          @@ self#parse_expression ~eq:Path.equal ~groups:uniq
+               ExpressionParser.path
         and* sort =
           S.field_opt_or ~default:[] "sort"
           @@ S.list
-               (self#parse_expression ~eq:Path.equal ~groups:uniq
-                  ExpressionParser.path)
+          @@ self#parse_expression ~eq:Path.equal ~groups:uniq
+               ExpressionParser.path
         in
         S.succeed @@ fun version source externals locale ->
         ImporterSyntax.
           { version; source; externals; columns; filters; sort; uniq; locale }
 
       method conf =
-        let* source = S.field "source" self#source
+        let* dataset : dataSet option =
+          S.field_opt_or ~default:None "dataset" self#load_resources
+        in
+
+        let* source = S.field "source" (self#source dataset)
         and* externals =
           S.field_opt_or ~default:[] "externals"
-            (S.key_value_pairs_seq self#external_)
+          @@ S.key_value_pairs_seq (self#external' dataset)
         and* locale = S.field_opt "locale" S.string in
         let* sheet =
           S.field "sheet" self#sheet >|= fun v -> v 1 source externals locale
@@ -272,15 +365,8 @@ module Make (S : Decoders.Decode.S) = struct
         S.succeed sheet
     end
 
-  let read_file file =
-    S.decode_file (new loader)#conf file
-    |> Result.map_error (fun v ->
-           let formatter = Format.str_formatter in
-           Format.fprintf formatter "%a@." S.pp_error v;
-           Format.flush_str_formatter ())
-
-  let read toml =
-    S.decode_value (new loader)#conf toml
+  let read context toml =
+    S.decode_value (new loader context)#conf toml
     |> Result.map_error (fun v ->
            let formatter = Format.str_formatter in
            Format.fprintf formatter "%a@." S.pp_error v;
diff --git a/lib/helpers/toml.ml b/lib/helpers/toml.ml
index 1b7fb15..5f441dc 100644
--- a/lib/helpers/toml.ml
+++ b/lib/helpers/toml.ml
@@ -1,9 +1,118 @@
+open StdLabels
+
+let rec pp :
+    ?topLevel:bool -> ?path:string list -> Format.formatter -> Otoml.t -> unit =
+ fun ?(topLevel = true) ?(path = []) format -> function
+  | Otoml.TomlString v -> begin
+      match String.contains v '\n' with
+      | false ->
+          Format.pp_print_string format "\"";
+          Format.pp_print_string format v;
+          Format.pp_print_string format "\""
+      | true ->
+          Format.pp_print_string format {|"""|};
+          Format.pp_print_text format v;
+          Format.pp_print_string format {|"""|}
+    end
+  | Otoml.TomlInteger i -> Format.pp_print_int format i
+  | Otoml.TomlFloat f -> Format.pp_print_float format f
+  | Otoml.TomlBoolean b -> Format.pp_print_bool format b
+  | Otoml.TomlArray l -> begin
+      match (topLevel, l) with
+      | _, [] -> Format.pp_print_string format "[]"
+      | false, _ -> Format.pp_print_string format "..."
+      | true, l ->
+          Format.pp_print_string format "[";
+          Format.pp_print_break format 0 4;
+          Format.pp_open_vbox format 0;
+          Format.pp_print_list
+            ~pp_sep:(fun f () ->
+              Format.pp_print_string f ",";
+              Format.pp_print_cut f ())
+            pp format l;
+          Format.pp_close_box format ();
+          Format.pp_print_cut format ();
+          Format.pp_print_string format "]"
+    end
+  | Otoml.TomlTable elements | Otoml.TomlInlineTable elements ->
+      pp_table ~path format elements
+  | Otoml.TomlTableArray t -> Format.pp_print_list pp format t
+  | Otoml.TomlOffsetDateTime _
+  | Otoml.TomlLocalDate _
+  | Otoml.TomlLocalDateTime _
+  | Otoml.TomlLocalTime _ -> ()
+
+and pp_key_values : Format.formatter -> string * Otoml.t -> unit =
+ fun format (name, value) ->
+  Format.fprintf format "%s = %a" name (pp ~topLevel:false ~path:[]) value
+
+and pp_table :
+    ?path:string list -> Format.formatter -> (string * Otoml.t) list -> unit =
+ fun ?(path = []) format elements ->
+  (* Create two lists, one for the subtables, and one for the values. 
+
+    As a table is valid until the next table, we then start to print the
+    preoperties before printintg the subtables inside the element.
+   *)
+  let subtables, properties =
+    List.partition elements ~f:(fun (_, v) ->
+        match v with
+        | Otoml.TomlTable _ -> true
+        | _ -> false)
+  in
+
+  let () =
+    match properties with
+    | [] -> ()
+    | _ ->
+        let isTopLevel =
+          match path with
+          | [] -> true
+          | _ -> false
+        in
+        if not isTopLevel then begin
+          let path = List.rev path in
+          Format.pp_print_cut format ();
+          Format.fprintf format "[%a]"
+            (Format.pp_print_list
+               ~pp_sep:(fun f () -> Format.pp_print_string f ".")
+               Format.pp_print_string)
+            path;
+          Format.pp_print_break format 0 4;
+          Format.pp_open_vbox format 0
+        end;
+        if isTopLevel then begin
+          Format.pp_print_list ~pp_sep:Format.pp_print_cut
+            (fun format v ->
+              match v with
+              | key, Otoml.TomlTable elements ->
+                  pp_table ~path:(key :: path) format elements
+              | other -> pp_key_values format other)
+            format properties
+        end
+        else begin
+          Format.pp_print_string format "..."
+        end;
+
+        if not isTopLevel then begin
+          Format.pp_close_box format ()
+        end;
+        Format.pp_print_cut format ()
+  in
+  (* Then go deeper inside each subtable *)
+  List.iter subtables ~f:(function
+    | name, Otoml.TomlTable v -> pp_table ~path:(name :: path) format v
+    | _ -> (* Because of the partition, this should not happen *) ())
+
 module Decode = struct
   module S = struct
     type value = Otoml.t
 
     let pp : Format.formatter -> value -> unit =
-     fun format t -> Format.pp_print_string format (Otoml.Printer.to_string t)
+     fun formatter v ->
+      Format.pp_open_vbox formatter 0;
+      pp formatter v;
+      Format.pp_close_box formatter ()
 
     let of_string : string -> (value, string) result =
       Otoml.Parser.from_string_result
@@ -22,7 +131,7 @@ module Decode = struct
 
     let get_key_value_pairs : value -> (value * value) list option =
       Otoml.get_opt (fun key ->
-          Otoml.get_table key |> List.map (fun (k, v) -> (Otoml.string k, v)))
+          Otoml.get_table key |> List.map ~f:(fun (k, v) -> (Otoml.string k, v)))
 
     let to_list : value list -> value = Otoml.array
   end
diff --git a/lib/syntax/importerSyntax.ml b/lib/syntax/importerSyntax.ml
index 7788613..cfbba81 100644
--- a/lib/syntax/importerSyntax.ml
+++ b/lib/syntax/importerSyntax.ml
@@ -128,7 +128,7 @@ let dummy_conf =
   {
     source = { file = ""; tab = 0; name = "" };
     version = latest_version;
-    locale = Some "C";
+    locale = None;
     externals = [];
     columns = [];
     filters = [];