Add a simple-json format for tests

The simple format doesn't have conditional break hints, thus it should
not sensitive to the difference of file name length on Windows

core/args.ml

@@ -50,6 +50,7 @@ let param0 = {
     no_include = false;
     may_approx = false;
     nested = false;
+    pretty_format = true;
     internal_format = Sexp;
     external_format = Json
   }
@@ -116,6 +117,7 @@ let format param x =
   match x with
     | "sexp" -> update Schematic.Sexp
     | "json" -> update Schematic.Json
+    | "simple-json" -> param#<-(L.pretty_fmt,false); update Schematic.Json
     | _ -> ()
 
 

core/io.ml

@@ -60,7 +60,7 @@ let direct = {
   writer = {
     m2l =  (fun format _filename ppf m2l ->
         match format with
-        | Json -> Schematic.minify ppf "%a@.\n" (Schematic.Ext.json Schema.m2l) m2l
+        | Json -> Schematic.minify ppf "%a@.\n" (Schematic.Ext.simple_json Schema.m2l) m2l
         | Sexp ->  Schematic.minify ppf "%a@.\n" (Schematic.Ext.sexp Schema.m2l) m2l
 
       );
@@ -70,7 +70,7 @@ let direct = {
          | Sexp ->  Schematic.minify ppf "%a@.\n"
                       (Schematic.Ext.sexp Schema.namespace) mds
          | Json ->  Schematic.minify ppf "%a@.\n"
-                      (Schematic.Ext.json Schema.namespace) mds
+                      (Schematic.Ext.simple_json Schema.namespace) mds
       )
   }
 }

core/modes.ml

@@ -63,7 +63,10 @@ let structured fmt _ _ ppf param units =
   let fmt = Option.default param.external_format fmt in
   let all = units.Unit.mli @ units.ml in
   let pp = let open Schematic in
-    match fmt with Json -> Ext.json Schema.x | Sexp -> Ext.sexp Schema.x in
+    match fmt, param.pretty_format with
+    | Json, true -> Ext.pretty_json Schema.x
+    | Json, false -> Ext.simple_json Schema.x
+    | Sexp, _ -> Ext.sexp Schema.x in
   let lib, unknown =
     List.fold_left build_atlas (LibSet.empty, Namespaced.Set.empty) all in
   let groups = Unit.Group.group units in

core/params.ml

@@ -6,6 +6,7 @@ type t =
     no_include:bool;
     may_approx:bool;
     nested: bool;
+    pretty_format:bool;
     internal_format: Schematic.format;
     external_format: Schematic.format
   }
@@ -41,6 +42,11 @@ module L = struct
   let may_approx =
     create (fun x -> x.may_approx) (fun x y -> { x with may_approx = y})
 
+  let pretty_fmt =
+    create
+      (fun x -> x.pretty_format)
+      (fun x y -> { x with pretty_format=y })
+
   let inner_fmt =
     create
       (fun x -> x.internal_format)

core/params.mli

@@ -7,6 +7,7 @@ type t = {
   no_include : bool;
   may_approx : bool;
   nested:bool;
+  pretty_format:bool;
   internal_format: Schematic.format;
   external_format: Schematic.format;
 }
@@ -54,4 +55,5 @@ module L :
     val nested : (t,bool) l
     val inner_fmt : (t, Schematic.format) l
     val ext_fmt : (t,Schematic.format) l
+    val pretty_fmt: (t,bool) l
   end

lib/schematic.ml

@@ -386,66 +386,134 @@ let json_definitions epaths ppf map =
   and json_defs ppf m = ignore (Name.Map.fold (json_def ppf) m false) in
   json_defs ppf map
 
-let rec json: type a f. f pending_rec_def -> (a,f) s -> Format.formatter -> a -> unit =
-  fun defs sch ppf x -> match sch, x with
-    | Int, n -> Pp.fp ppf "%d" n
-    | Float, f -> Pp.fp ppf "%f" f
-    | String, s -> Pp.estring ppf s
-    | Bool, b -> Pp.fp ppf "%b" b
-    | Void, _ -> .
-    | Array k, l ->
-      Pp.fp ppf "@[<hov>[%a]@]"
-        (Pp.list ~sep:(Pp.s ",@ ") @@ json defs k) l
-    | [], [] -> ()
-    | _ :: _ as sch , l -> Pp.fp ppf "@[<hov>[%a]@]" (json_tuple defs sch) l
-    | Obj sch, x -> Pp.fp ppf "@[<hv>{@ %a@ }@]" (json_obj false defs sch) x
-    | Custom c, x -> json defs c.sch ppf (c.fwd x)
-    | Sum q, x -> json_sum 0 defs q ppf x
-    | Description(_,sch), x -> json defs sch ppf x
-    | Var n, x ->
-      let Pending p = defs in
-      json defs (get p.defs n) ppf x
-    | Rec { defs; id; proj; _ }, x -> json (Pending {defs; id}) (get defs proj) ppf x
-and json_sum: type all x. int -> all pending_rec_def -> (x,all) sum_decl  ->
-  Format.formatter -> x sum -> unit =
-  fun n defs sch ppf x -> match sch, x with
-    | (n,a) :: _ , C Z x ->
-      let module N = Label(struct let l=n end) in
-      json defs (Obj [Req, N.l, a]) ppf (Record.[N.l, x])
-    | (n,_) :: _ , C E ->
-      json defs String ppf n
-    | _ :: q, C S c -> json_sum (n+1) defs q ppf (C c)
-    | [], _ -> .
-
-and json_tuple: type a f. f pending_rec_def -> (a tuple,f) s -> Format.formatter -> a tuple -> unit =
-  fun defs sch ppf x -> match sch, x with
-    | [], [] -> ()
-    | [a], [x] -> json defs a ppf x
-    | a :: q, x :: xs -> Pp.fp ppf "%a,@ %a" (json defs a) x (json_tuple defs q) xs
-    | Custom _, _ -> assert false
-    | Description _, _ -> assert false
-    | Rec { defs; proj; id; _ }, x -> json_tuple (Pending {id;defs}) (get defs proj) ppf x
-    | Var proj, x ->
-      let Pending p =  defs in
-      json_tuple defs (get p.defs proj) ppf x
+module Pretty_json = struct
+
+  let rec json: type a f. f pending_rec_def -> (a,f) s -> Format.formatter -> a -> unit =
+    fun defs sch ppf x -> match sch, x with
+      | Int, n -> Pp.fp ppf "%d" n
+      | Float, f -> Pp.fp ppf "%f" f
+      | String, s -> Pp.estring ppf s
+      | Bool, b -> Pp.fp ppf "%b" b
+      | Void, _ -> .
+      | Array k, l ->
+        Pp.fp ppf "@[<hov>[%a]@]"
+          (Pp.list ~sep:(Pp.s ",@ ") @@ json defs k) l
+      | [], [] -> ()
+      | _ :: _ as sch , l -> Pp.fp ppf "@[<hov>[%a]@]" (json_tuple defs sch) l
+      | Obj sch, x -> Pp.fp ppf "@[<hv>{@ %a@ }@]" (json_obj false defs sch) x
+      | Custom c, x -> json defs c.sch ppf (c.fwd x)
+      | Sum q, x -> json_sum 0 defs q ppf x
+      | Description(_,sch), x -> json defs sch ppf x
+      | Var n, x ->
+        let Pending p = defs in
+        json defs (get p.defs n) ppf x
+      | Rec { defs; id; proj; _ }, x -> json (Pending {defs; id}) (get defs proj) ppf x
+  and json_sum: type all x. int -> all pending_rec_def -> (x,all) sum_decl  ->
+    Format.formatter -> x sum -> unit =
+    fun n defs sch ppf x -> match sch, x with
+      | (n,a) :: _ , C Z x ->
+        let module N = Label(struct let l=n end) in
+        json defs (Obj [Req, N.l, a]) ppf (Record.[N.l, x])
+      | (n,_) :: _ , C E ->
+        json defs String ppf n
+      | _ :: q, C S c -> json_sum (n+1) defs q ppf (C c)
+      | [], _ -> .
+
+  and json_tuple: type a f. f pending_rec_def -> (a tuple,f) s -> Format.formatter -> a tuple -> unit =
+    fun defs sch ppf x -> match sch, x with
+      | [], [] -> ()
+      | [a], [x] -> json defs a ppf x
+      | a :: q, x :: xs -> Pp.fp ppf "%a,@ %a" (json defs a) x (json_tuple defs q) xs
+      | Custom _, _ -> assert false
+      | Description _, _ -> assert false
+      | Rec { defs; proj; id; _ }, x -> json_tuple (Pending {id;defs}) (get defs proj) ppf x
+      | Var proj, x ->
+        let Pending p =  defs in
+        json_tuple defs (get p.defs proj) ppf x
+
+  and json_obj: type a r.
+    bool -> r pending_rec_def -> (a,r) record_declaration -> Format.formatter -> a record -> unit =
+    fun not_first defs sch ppf x -> match sch, x with
+      | [], [] -> ()
+      | (Req, name,sch) :: q ,   (_, x) :: xs ->
+        if not_first then Pp.fp ppf ",@ ";
+        Pp.fp ppf {|@[<hov 2>"%s"@ :@ %a@]|} (show name) (json defs sch) x;
+        Pp.fp ppf "%a" (json_obj true defs q) xs
+      | (Opt,name,sch) :: q, (_,Some x) :: xs ->
+        if not_first then Pp.fp ppf ",@ ";
+        Pp.fp ppf {|@[<hov 2>"%s"@ :@ %a@]|} (show name) (json defs sch) x;
+        Pp.fp ppf "%a" (json_obj true defs q) xs
+      | (Opt,_,_) :: q, (_, None ) :: xs ->
+        json_obj not_first defs q ppf xs
+end
 
-and json_obj: type a r.
-  bool -> r pending_rec_def -> (a,r) record_declaration -> Format.formatter -> a record -> unit =
-  fun not_first defs sch ppf x -> match sch, x with
-    | [], [] -> ()
-    | (Req, name,sch) :: q ,   (_, x) :: xs ->
-      if not_first then Pp.fp ppf ",@ ";
-      Pp.fp ppf {|@[<hov 2>"%s"@ :@ %a@]|} (show name) (json defs sch) x;
-      Pp.fp ppf "%a" (json_obj true defs q) xs
-    | (Opt,name,sch) :: q, (_,Some x) :: xs ->
-      if not_first then Pp.fp ppf ",@ ";
-      Pp.fp ppf {|@[<hov 2>"%s"@ :@ %a@]|} (show name) (json defs sch) x;
-      Pp.fp ppf "%a" (json_obj true defs q) xs
-    | (Opt,_,_) :: q, (_, None ) :: xs ->
-      json_obj not_first defs q ppf xs
+let pretty_json x = Pretty_json.json Closed x
+
+module Simple_json = struct
+
+  let rec json: type a f. f pending_rec_def -> (a,f) s -> Format.formatter -> a -> unit =
+    fun defs sch ppf x -> match sch, x with
+      | Int, n -> Pp.fp ppf "%d" n
+      | Float, f -> Pp.fp ppf "%f" f
+      | String, s -> Pp.estring ppf s
+      | Bool, b -> Pp.fp ppf "%b" b
+      | Void, _ -> .
+      | Array k, l ->
+        Pp.fp ppf "@[<v>[%a]@]"
+          (Pp.list ~sep:(Pp.s ",@ ") @@ json defs k) l
+      | [], [] -> ()
+      | _ :: _ as sch , l -> Pp.fp ppf "@[<h>[%a]@]" (tuple defs sch) l
+      | Obj sch, x -> Pp.fp ppf "@[<v>{@ %a@ }@]" (obj false defs sch) x
+      | Custom c, x -> json defs c.sch ppf (c.fwd x)
+      | Sum q, x -> sum 0 defs q ppf x
+      | Description(_,sch), x -> json defs sch ppf x
+      | Var n, x ->
+        let Pending p = defs in
+        json defs (get p.defs n) ppf x
+      | Rec { defs; id; proj; _ }, x -> json (Pending {defs; id}) (get defs proj) ppf x
+  and sum: type all x. int -> all pending_rec_def -> (x,all) sum_decl  ->
+    Format.formatter -> x sum -> unit =
+    fun n defs sch ppf x -> match sch, x with
+      | (n,a) :: _ , C Z x ->
+        let module N = Label(struct let l=n end) in
+        json defs (Obj [Req, N.l, a]) ppf (Record.[N.l, x])
+      | (n,_) :: _ , C E ->
+        json defs String ppf n
+      | _ :: q, C S c -> sum (n+1) defs q ppf (C c)
+      | [], _ -> .
+
+  and tuple: type a f. f pending_rec_def -> (a tuple,f) s -> Format.formatter -> a tuple -> unit =
+    fun defs sch ppf x -> match sch, x with
+      | [], [] -> ()
+      | [a], [x] -> json defs a ppf x
+      | a :: q, x :: xs -> Pp.fp ppf "%a,@ %a" (json defs a) x (tuple defs q) xs
+      | Custom _, _ -> assert false
+      | Description _, _ -> assert false
+      | Rec { defs; proj; id; _ }, x -> tuple (Pending {id;defs}) (get defs proj) ppf x
+      | Var proj, x ->
+        let Pending p =  defs in
+        tuple defs (get p.defs proj) ppf x
+
+  and obj: type a r.
+    bool -> r pending_rec_def -> (a,r) record_declaration -> Format.formatter -> a record -> unit =
+    fun not_first defs sch ppf x -> match sch, x with
+      | [], [] -> ()
+      | (Req, name,sch) :: q ,   (_, x) :: xs ->
+        if not_first then Pp.fp ppf ",@ ";
+        Pp.fp ppf {|@[<v 2>"%s":@ %a@]|} (show name) (json defs sch) x;
+        Pp.fp ppf "%a" (obj true defs q) xs
+      | (Opt,name,sch) :: q, (_,Some x) :: xs ->
+        if not_first then Pp.fp ppf ",@ ";
+        Pp.fp ppf {|@[<v 2>"%s":@ %a@]|} (show name) (json defs sch) x;
+        Pp.fp ppf "%a" (obj true defs q) xs
+      | (Opt,_,_) :: q, (_, None ) :: xs ->
+        obj not_first defs q ppf xs
 
+end
 
-let json x = json Closed x
+
+
+let simple_json x = Simple_json.json Closed x
 
 let cstring ppf s =
   begin try
@@ -703,9 +771,14 @@ module Ext = struct
 
 
 
-  let json s ppf x =
+  let pretty_json s ppf x =
     let B (sch, x) = extend s x in
-    json sch ppf x
+    pretty_json sch ppf x
+
+  let simple_json s ppf x =
+    let B (sch, x) = extend s x in
+    simple_json sch ppf x
+
 
   let json_schema ppf s =
     let Dyn (rctx,sch) = schema s in

lib/schematic.mli

@@ -99,7 +99,9 @@ module Version: sig
 end
 
 
-val json: 'a t -> Format.formatter -> 'a -> unit
+val pretty_json: 'a t -> Format.formatter -> 'a -> unit
+val simple_json: 'a t -> Format.formatter -> 'a -> unit
+
 val sexp: 'a t  -> Format.formatter -> 'a -> unit
 
 val ($=): 'a label -> 'b -> ('a label * 'b)
@@ -146,7 +148,8 @@ type error =
   | Parse_error
 
 
-val json: ('lbl,'a) t -> Format.formatter -> 'a -> unit
+val pretty_json: ('lbl,'a) t -> Format.formatter -> 'a -> unit
+val simple_json: ('lbl,'a) t -> Format.formatter -> 'a -> unit
 val sexp: ('lbl,'a) t  -> Format.formatter -> 'a -> unit
 val json_schema:  Format.formatter -> ('lbl, 'a) t -> unit
 

tests/cases/abstract_module_type.ref

@@ -1,9 +1,16 @@
 {
-"version" : [0, 11, 0],
-"dependencies" : [{ "file" : "cases/abstract_module_type.ml" }],
-"local" :
+"version":
+  [0, 11, 0],
+"dependencies":
   [{
-   "module" : ["Abstract_module_type"],
-   "ml" : "cases/abstract_module_type.ml"
+   "file":
+     "cases/abstract_module_type.ml"
+   }],
+"local":
+  [{
+   "module":
+     ["Abstract_module_type"],
+   "ml":
+     "cases/abstract_module_type.ml"
    }]
 }

tests/cases/abstract_module_type_more.ref

@@ -1,11 +1,18 @@
 [Warning]: cases/abstract_module_type_more.ml:l25.0−11,
 module B.R does not contain any submodule XI
 {
-"version" : [0, 11, 0],
-"dependencies" : [{ "file" : "cases/abstract_module_type_more.ml" }],
-"local" :
+"version":
+  [0, 11, 0],
+"dependencies":
   [{
-   "module" : ["Abstract_module_type_more"],
-   "ml" : "cases/abstract_module_type_more.ml"
+   "file":
+     "cases/abstract_module_type_more.ml"
+   }],
+"local":
+  [{
+   "module":
+     ["Abstract_module_type_more"],
+   "ml":
+     "cases/abstract_module_type_more.ml"
    }]
 }

tests/cases/alias_in_with.ref

@@ -5,12 +5,26 @@ a non-resolvable module, Ext2, has been replaced by an approximation
 [Notification]: cases/alias_in_with.ml:l26.0−l28.27,
 a non-resolvable module, Ext3, has been replaced by an approximation
 {
-"version" : [0, 11, 0],
-"dependencies" :
+"version":
+  [0, 11, 0],
+"dependencies":
   [{
-   "file" : "cases/alias_in_with.ml",
-   "deps" : [["Ext3"], ["Ext2"], ["Ext"]]
+   "file":
+     "cases/alias_in_with.ml",
+   "deps":
+     [["Ext3"],
+     ["Ext2"],
+     ["Ext"]]
    }],
-"local" : [{ "module" : ["Alias_in_with"], "ml" : "cases/alias_in_with.ml" }],
-"unknown" : [["Ext"], ["Ext2"], ["Ext3"]]
+"local":
+  [{
+   "module":
+     ["Alias_in_with"],
+   "ml":
+     "cases/alias_in_with.ml"
+   }],
+"unknown":
+  [["Ext"],
+  ["Ext2"],
+  ["Ext3"]]
 }