adds YAML as an alternative output of the specification command (#1295)

Motivation: YAML is both human-readable and machine-readbale and
together with yq it is possible to easily construct various queries or
translate it to json and other formats.

Also adds a corresponding `Ogre.Doc.pp_yaml` function.

Author: ivg

lib/ogre/ogre.ml

@@ -380,6 +380,45 @@ module Doc = struct
   let pp ppf t =
     fprintf ppf "%a@\n%a" pp_scheme t pp_body t
 
+  module Yaml = struct
+    let pp_typ ppf typ =
+      pp_print_string ppf (Type.string_of_typ typ)
+
+    let pp_headers = pp_print_list
+        ~pp_sep:(fun ppf () -> pp_print_string ppf ", ")
+        (fun ppf {Type.fname; ftype} ->
+           fprintf ppf "%S : %a" fname pp_typ ftype)
+
+    let pp_scheme ppf {scheme} =
+      fprintf ppf "scheme:@\n";
+      Map.iteri scheme ~f:(fun ~key:n ~data:s ->
+          fprintf ppf "  %S : {%a}@\n" n pp_headers s)
+
+
+    let pp_objects = pp_print_list
+        ~pp_sep:(fun ppf () -> pp_print_string ppf "    ")
+        pp_print_string
+
+    let pp_body ppf {scheme; entries} =
+      Map.iteri entries ~f:(fun ~key:name ~data:entries ->
+          fprintf ppf "%S:@\n" name;
+          List.iter entries ~f:(fun {fields} ->
+              let objects =
+                List.map (Map.find_exn scheme name) ~f:(fun {fname; ftype} ->
+                    let v = Map.find_exn fields fname in
+                    match ftype with
+                    | Type.Str -> asprintf "%S: %S@\n" fname v
+                    | _ -> asprintf "%S: %s@\n" fname v) in
+              match objects with
+              | [] -> ()
+              | _ -> fprintf ppf "  - %a" pp_objects objects))
+    let pp ppf doc =
+      pp_scheme ppf doc;
+      pp_body ppf doc
+  end
+
+  let pp_yaml = Yaml.pp
+
   let load channel = Or_error.try_with_join ~backtrace:true (fun () ->
       of_sexps (Sexp.input_sexps channel))
 

lib/ogre/ogre.mli

@@ -559,6 +559,11 @@ module Doc : sig
   (** [pp ppf doc] prints a [doc] in the specified formatter [ppf]  *)
   val pp : Format.formatter -> doc -> unit
 
+  (** [pp_yamp ppf doc] prints doc to [ppf] in the YAML format.
+
+      @since 2.3.0  *)
+  val pp_yaml : Format.formatter -> doc -> unit
+
 
   (** [clear doc] removes all facts from the document.
 

plugins/specification/specification_main.ml

@@ -18,7 +18,18 @@ type Extension.Error.t += Fail of problem
 
 
 let input = Extension.Command.argument
-    ~doc:"The input file" Extension.Type.("FILE" %: string =? "a.out" )
+    ~doc:"The input file"
+    Extension.Type.("FILE" %: string =? "a.out")
+
+let formats = [
+  "sexp", `Sexp;
+  "yaml", `Yaml;
+]
+
+let format = Extension.Command.parameter
+    (Extension.Type.enum formats) "format"
+    ~aliases:["o"]
+    ~doc:"The output format"
 
 let loader =
   Extension.Command.parameter
@@ -34,26 +45,29 @@ let reader = Data.Read.create ()
 let writer = Data.Write.create ()
     ~to_bigstring:(Binable.to_bigstring (module Ogre.Doc))
 
+let print fmt spec =
+  let pp = match fmt with
+    | `Yaml -> Ogre.Doc.pp_yaml
+    | `Sexp -> Ogre.Doc.pp in
+  Format.printf "%a@\n%!" pp spec
+
 let () = Extension.Command.(begin
-    declare "specification" (args $input $loader)
+    declare "specification" (args $format $input $loader)
       ~doc
       ~requires:["loader"]
-  end) @@ fun input loader ctxt ->
+  end) @@ fun format input loader ctxt ->
   let digest = Data.Cache.Digest.create ~namespace:"specification" in
   let digest = Data.Cache.Digest.add digest "%s%s%s"
       input loader (Extension.Configuration.digest ctxt) in
   let cache = Data.Cache.Service.request reader writer in
   match Data.Cache.load cache digest with
-  | Some spec ->
-    Format.printf "%a@\n%!" Ogre.Doc.pp spec;
-    Ok ()
+  | Some spec -> print format spec; Ok ()
   | None -> match Image.find_loader loader with
     | None -> problem (Unknown_loader loader)
     | Some (module Load) -> match Load.from_file input with
       | Ok (Some spec) ->
         Data.Cache.save cache digest spec;
-        Format.printf "%a@\n%!" Ogre.Doc.pp spec;
-        Ok ()
+        print format spec; Ok ()
       | Ok None -> Ok ()
       | Error err -> problem (Loader_error err)