Documentation: add description to all the registration functions

 (metas, debug flags, transformations, formats) except for label.

This description is used in --list-*. The description can use any of
the formatting markup of Format "@ " "@[",...

Transformations can also specify from which metas and labels they
depend, and add informations about how they are interpreted.

TODO:
  - complete and correct the documentation
  - when a transformation use Trans.on_meta, it should be possible to
    add an interpretation of the metas in the documentation.
  - recover a summary version of --list-* ?
  - be able to export in latex?

bench/bench

@@ -98,6 +98,18 @@ valid_goals () {
     done
 }
 
+list_stuff () {
+    echo -n "$1 "
+    if $pgml $1 > /dev/null 2>&1; then
+        echo "ok"
+    else
+        echo "$pgm $1 FAIL"
+        $pgm $1
+        exit 1
+    fi
+}
+
+
 echo "=== Checking drivers ==="
 drivers drivers
 echo ""
@@ -154,3 +166,11 @@ echo "=== Checking valid goals ==="
 valid_goals bench/valid
 echo ""
 
+echo "=== Checking --list-* ==="
+list_stuff --list-transforms
+list_stuff --list-printers
+list_stuff --list-provers
+list_stuff --list-formats
+list_stuff --list-metas
+list_stuff --list-debug-flags
+echo ""

plugins/parser/genequlin.ml

@@ -131,3 +131,9 @@ let read_channel env path filename cin =
   (), Mstr.singleton "EqLin" (close_theory th_uc)
 
 let library_of_env = Env.register_format "EquLin" ["equlin"] read_channel
+  ~desc:"@[Generate rendomly linear arithmetic problems:@\n  \
+  @[The first line give the seed to use. Each other lines corresond to one goal@\n  \
+    @[- @[the first number give the number of variables@]@\n\
+      - @[the second the number of equation@]@\n\
+      - @[the third the absolute maximun of the constants used@]\
+@]"

plugins/tptp/tptp_lexer.mll

@@ -256,6 +256,7 @@ and comment_line = parse
     (), Tptp_typing.typecheck env path ast
 
   let library_of_env = Env.register_format "tptp" ["p";"ax"] read_channel
+    ~desc:"TFF1 TPTP format."
 }
 
 (*

plugins/tptp/tptp_printer.ml

@@ -235,4 +235,6 @@ let print_task fof _env pr thpr ?old:_ fmt task =
     (print_list nothing (print_decl info)) (Task.task_decls task)
 
 let () = register_printer "tptp-tff" (print_task false)
+  ~desc:"Printer for the TPTP-TFF format."
 let () = register_printer "tptp-fof" (print_task true)
+  ~desc:"Printer for the TPTP-FOF format."

share/bash/why3

@@ -39,12 +39,12 @@ _why3()
             return 0
             ;;
         -P|--prover)
-            provers=$($1 --list-provers | grep -v '^Known ' | cut -d ' ' -f 3)
+            provers=$($1 --list-provers | grep '^  [^ ]' | cut -d ' ' -f 3)
             COMPREPLY=( $( compgen -W "$provers" -- "$cur" ) )
             return 0
             ;;
         -F|--format)
-            formats=$($1 --list-formats | grep -v '^Known ' | cut -d ' ' -f 3)
+            formats=$($1 --list-formats | grep '^  [^ ]' | cut -d ' ' -f 3)
             COMPREPLY=( $( compgen -W "$formats" -- "$cur" ) )
             return 0
             ;;
@@ -52,12 +52,12 @@ _why3()
             return 0
             ;;
         -a|--apply-transform)
-            transforms=$($1 --list-transforms | grep -v '^Known ')
+            transforms=$($1 --list-transforms | grep '^  [^ ]')
             COMPREPLY=( $( compgen -W "$transforms" -- "$cur" ) )
             return 0
             ;;
         -M|--meta)
-            metas=$($1 --list-metas | grep -v '^Known ' |
+            metas=$($1 --list-metas | grep '^  [^ ]' |
                 grep -v '\[\(function/predicate\|type\) symbol\]' |
                 grep -v '\[\(type\|proposition\|integer\)\]' |
                 grep -v '\] \[' | sed -e 's/(flag) //' |
@@ -87,12 +87,12 @@ _why3()
             return 0
             ;;
         --debug)
-            flags=$($1 --list-debug-flags | grep -v '^Known ' | cut -d ' ' -f 3)
+            flags=$($1 --list-debug-flags | grep '^  [^ ]' | cut -d ' ' -f 3)
             COMPREPLY=( $( compgen -W "$flags" -- "$cur" ) )
             return 0
             ;;
         --filter-prover)
-            provers=$(${1/session/} --list-provers | grep -v '^Known ' | cut -d ' ' -f 3)
+            provers=$(${1/session/} --list-provers | grep '^  [^ ]' | cut -d ' ' -f 3)
             COMPREPLY=( $( compgen -W "$provers" -- "$cur" ) )
             return 0
             ;;

src/bench/bench.ml

@@ -84,7 +84,9 @@ type callback = tool_id -> prob_id ->
     task -> int ->  proof_attempt_status -> unit
 
 let debug_call = Debug.register_flag "call"
+  ~desc:"Show when call to provers are done"
 let debug = Debug.register_flag "bench_core"
+  ~desc:"About the scheduling"
 
 
 module BenchUtil =

src/bench/benchdb.ml

@@ -29,6 +29,7 @@ let load_driver = Env.Wenv.memoize 2 (fun env ->
   memo_string 10 (Driver.load_driver env))
 
 let debug = Debug.register_flag "benchdb"
+  ~desc:"About the communication from the database"
 
 type path =
   | Pgoal of string

src/bench/whybench.ml

@@ -30,9 +30,10 @@ module B = Bench
 module C = Call_provers
 
 let debug = Debug.register_flag "main"
+  ~desc:"About initialization of the bench"
 
 let usage_msg = sprintf
-  "Usage: %s [options] [[file|-] [-T <theory> [-G <goal>]...]...]...
+  "Usage: %s [options] [[file|-] [-T <theory> [-G <goal>]...]...]...\
   [-P <prover> ]..."
   (Filename.basename Sys.argv.(0))
 
@@ -219,52 +220,51 @@ let () =
 
   (** listings*)
 
+  let sort_pair (x,_) (y,_) = String.compare x y in
   let opt_list = ref false in
-  if !opt_version then begin
-    opt_list := true;
-    printf "%s@." version_msg
-  end;
   if !opt_list_transforms then begin
     opt_list := true;
     printf "@[<hov 2>Known non-splitting transformations:@\n%a@]@\n@."
-      (Pp.print_list Pp.newline Pp.string)
-      (List.sort String.compare (Trans.list_transforms ()));
+      (Pp.print_list Pp.newline Trans.print_trans_desc)
+      (List.sort sort_pair (Trans.list_transforms ()));
     printf "@[<hov 2>Known splitting transformations:@\n%a@]@\n@."
-      (Pp.print_list Pp.newline Pp.string)
-      (List.sort String.compare (Trans.list_transforms_l ()))
+      (Pp.print_list Pp.newline Trans.print_trans_desc)
+      (List.sort sort_pair (Trans.list_transforms_l ()))
   end;
   if !opt_list_printers then begin
     opt_list := true;
     printf "@[<hov 2>Known printers:@\n%a@]@\n@."
-      (Pp.print_list Pp.newline Pp.string)
-      (List.sort String.compare (Printer.list_printers ()))
+      (Pp.print_list Pp.newline Printer.print_printer_desc)
+      (List.sort sort_pair (Printer.list_printers ()))
   end;
   if !opt_list_formats then begin
     opt_list := true;
     let print1 fmt s = fprintf fmt "%S" s in
-    let print fmt (p, l) =
-      fprintf fmt "%s [%a]" p (Pp.print_list Pp.comma print1) l
+    let print fmt (p, l, f) =
+      fprintf fmt "@[%s [%a]@\n  @[%a@]@]"
+        p (Pp.print_list Pp.comma print1) l
+        Pp.formatted f
     in
-    printf "@[<hov 2>Known input formats:@\n%a@]@."
+    printf "@[Known input formats:@\n  @[%a@]@]@."
       (Pp.print_list Pp.newline print)
       (List.sort Pervasives.compare (Env.list_formats ()))
   end;
   if !opt_list_provers then begin
     opt_list := true;
     let config = read_config !opt_config in
-    let print fmt prover pc = fprintf fmt "%a (%a)@\n"
-      print_prover_parsable_format pc.prover print_prover prover in
-    let print fmt m = Mprover.iter (print fmt) m in
+    let print = Pp.print_iter2 Mprover.iter Pp.newline Pp.nothing
+      print_prover Pp.nothing in
     let provers = get_provers config in
     printf "@[<hov 2>Known provers:@\n%a@]@." print provers
   end;
   if !opt_list_metas then begin
     opt_list := true;
-    let print fmt m = fprintf fmt "@[%s %s%a@]"
+    let print fmt m = fprintf fmt "@[<h 2>%s %s%a@\n@[<hov>%a@]@]"
       (let s = m.meta_name in
         if String.contains s ' ' then "\"" ^ s ^ "\"" else s)
-      (if m.meta_excl then "* " else "")
+      (if m.meta_excl then "(flag) " else "")
       (Pp.print_list Pp.space Pretty.print_meta_arg_type) m.meta_type
+      Pp.formatted m.meta_desc
     in
     let cmp m1 m2 = Pervasives.compare m1.meta_name m2.meta_name in
     printf "@[<hov 2>Known metas:@\n%a@]@\n@."
@@ -311,7 +311,7 @@ let () =
     && (not !opt_redo)
   then
     begin
-      eprintf "At least one bench is required or one prover and one file or
+      eprintf "At least one bench is required or one prover and one file or\n\
       the verification of a database .@.";
       Arg.usage option_list usage_msg;
       exit 1

src/config/whyconfig.ml

@@ -24,8 +24,8 @@ open Util
 open Whyconf
 
 let usage_msg =
-  sprintf "Usage: %s [options]\n
-  Environment variables WHY3LIB, WHY3DATA, and WHY3CONFIG
+  sprintf "Usage: %s [options]\n\
+  Environment variables WHY3LIB, WHY3DATA, and WHY3CONFIG\n\
   can be set to change the default paths.@."
     (Filename.basename Sys.argv.(0))
 

src/core/env.ml

@@ -64,7 +64,7 @@ let lookup_format name =
   with Not_found -> raise (UnknownFormat name)
 
 let list_formats () =
-  let add n (_,_,l) acc = (n,l)::acc in
+  let add n (_,_,l,desc) acc = (n,l,desc)::acc in
   Hashtbl.fold add read_format_table []
 
 let get_extension file =
@@ -82,7 +82,7 @@ let read_channel ?format env file ic =
   let name = match format with
     | Some name -> name
     | None -> get_format file in
-  let rc,_,_ = lookup_format name in
+  let rc,_,_,_ = lookup_format name in
   rc env file ic
 
 let read_file ?format env file =
@@ -94,7 +94,7 @@ let read_file ?format env file =
   with e -> close_in ic; raise e
 
 let read_theory ~format env path th =
-  let _,rl,_ = lookup_format format in
+  let _,rl,_,_ = lookup_format format in
   rl env path th
 
 let find_theory = read_theory ~format:"why"
@@ -180,17 +180,17 @@ let read_lib_theory lib path th =
   try Mstr.find th mth with Not_found ->
   raise (TheoryNotFound (path,th))
 
-let register_format name exts read =
+let register_format ~(desc:Pp.formatted) name exts read =
   if Hashtbl.mem read_format_table name then raise (KnownFormat name);
   let getlib = Wenv.memoize 5 (mk_library read exts) in
   let rc env file ic = snd (read (getlib env) [] file ic) in
   let rl env path th = read_lib_theory (getlib env) path th in
-  Hashtbl.add read_format_table name (rc,rl,exts);
+  Hashtbl.add read_format_table name (rc,rl,exts,desc);
   List.iter (fun s -> Hashtbl.replace extensions_table s name) exts;
   getlib
 
 let locate_lib_file env format path =
-  let _,_,exts = lookup_format format in
+  let _,_,exts,_ = lookup_format format in
   locate_lib_file env path exts
 
 (* Exception reporting *)

src/core/env.mli

@@ -70,7 +70,7 @@ val read_file : ?format:fformat -> env -> filename -> theory Mstr.t
 
 val read_theory : format:fformat -> env -> pathname -> string -> theory
 (** [read_theory ~format env path th] returns the theory [path.th]
-    from the library. The parameter [format] speicifies the format
+    from the library. The parameter [format] specifies the format
     of the library file to look for.
 
     @raise UnknownFormat [format] if the format is not registered
@@ -100,6 +100,7 @@ type 'a read_format =
     (e.g. file name) to be used in error messages. *)
 
 val register_format :
+  desc:Pp.formatted ->
   fformat -> extension list -> 'a read_format -> (env -> 'a library)
 (** [register_format fname exts read] registers a new format [fname]
     for files with extensions from the string list [exts] (without
@@ -112,7 +113,7 @@ val register_format :
 val env_of_library : 'a library -> env
 (** [env_of_library lib] returns the environment of [lib] *)
 
-val list_formats : unit -> (fformat * extension list) list
+val list_formats : unit -> (fformat * extension list * Pp.formatted) list
 (** [list_formats ()] returns the list of registered formats *)
 
 val read_lib_file : 'a library -> pathname -> 'a * theory Mstr.t

src/core/ident.ml

@@ -169,6 +169,7 @@ let forget_all printer =
 (** Sanitizers *)
 
 let unsanitizable = Debug.register_flag "unsanitizable"
+  ~desc:"About@ the@ sanitazing@ during@ the@ pretty-printing."
 
 let char_to_alpha c = match c with
   | 'a'..'z' | 'A'..'Z' -> String.make 1 c

src/core/pretty.ml

@@ -28,8 +28,12 @@ open Decl
 open Theory
 open Task
 
+(* TODO: Is it not an example of register_stop_flag? *)
 let debug_print_labels = Debug.register_flag "print_labels"
+  ~desc:"Control if ident labels are printed."
+
 let debug_print_locs = Debug.register_flag "print_locs"
+  ~desc:"Control if ident location are printed."
 
 let iprinter,aprinter,tprinter,pprinter =
   let bl = ["theory"; "type"; "constant"; "function"; "predicate"; "inductive";

src/core/printer.ml

@@ -36,22 +36,33 @@ type 'a pp = formatter -> 'a -> unit
 
 type printer = Env.env -> prelude -> prelude_map -> ?old:in_channel -> task pp
 
-let printers : (string, printer) Hashtbl.t = Hashtbl.create 17
+type reg_printer =
+  { reg_desc    : formatted;
+    reg_printer : printer;
+  }
+
+let printers : (string, reg_printer) Hashtbl.t = Hashtbl.create 17
 
 exception KnownPrinter of string
 exception UnknownPrinter of string
 
-let register_printer s p =
+let register_printer ~desc s p =
   if Hashtbl.mem printers s then raise (KnownPrinter s);
-  Hashtbl.replace printers s p
+  Hashtbl.replace printers s {reg_desc = desc; reg_printer = p}
 
 let lookup_printer s =
-  try Hashtbl.find printers s
+  try (Hashtbl.find printers s).reg_printer
   with Not_found -> raise (UnknownPrinter s)
 
-let list_printers ()  = Hashtbl.fold (fun k _ acc -> k::acc) printers []
+let list_printers ()  = Hashtbl.fold (fun k p acc ->
+  (k,p.reg_desc)::acc) printers []
+
+let print_printer_desc fmt (s,f) =
+  fprintf fmt "@[<hov 2>%s@\n@[<hov>%a@]@]"
+    s Pp.formatted f
 
-let () = register_printer "(null)" (fun _ _ _ ?old:_ _ _ -> ())
+let () = register_printer ~desc:"Print nothing" "(null)"
+  (fun _ _ _ ?old:_ _ _ -> ())
 
 (** Syntax substitutions *)
 
@@ -193,9 +204,20 @@ exception KnownTypeSyntax of tysymbol
 exception KnownLogicSyntax of lsymbol
 
 let meta_syntax_type  = register_meta "syntax_type" [MTtysymbol; MTstring]
+  ~desc:"Specify@ the@ syntax@ used@ to@ pretty-print@ the@ type@ symbols.@ \
+         Can@ be@ specified@ in@ the@ driver@ with@ the@ 'syntax type'@ rule."
+
 let meta_syntax_logic = register_meta "syntax_logic" [MTlsymbol; MTstring]
+  ~desc:"Specify@ the@ syntax@ used@ to@ pretty-print@ the@ logic@ symbols.@ \
+         Can@ be@ specified@ in@ the@ driver@ with@ the@ 'syntax function'@ \
+         rule."
+
 let meta_remove_prop  = register_meta "remove_prop" [MTprsymbol]
+  ~desc:"Specify@ the@ logical@ propositions@ to@ remove.@ \
+         Can@ be@ specified@ in@ the@ driver@ with@ the@ remove@ prop@ rule."
+
 let meta_realized     = register_meta "realized" [MTstring; MTstring]
+  ~desc:"TODO??"
 
 let syntax_type ts s =
   check_syntax s (List.length ts.ts_args);

src/core/printer.mli

@@ -34,11 +34,12 @@ type 'a pp = Format.formatter -> 'a -> unit
 
 type printer = Env.env -> prelude -> prelude_map -> ?old:in_channel -> task pp
 
-val register_printer : string -> printer -> unit
+val register_printer : desc:Pp.formatted -> string -> printer -> unit
 
 val lookup_printer : string -> printer
 
-val list_printers : unit -> string list
+val list_printers : unit -> (string * Pp.formatted) list
+val print_printer_desc : Pp.formatter -> (string * Pp.formatted) -> unit
 
 (** {2 use printers} *)
 

src/core/theory.ml

@@ -103,8 +103,13 @@ type meta = {
   meta_type : meta_arg_type list;
   meta_excl : bool;
   meta_tag  : int;
+  mutable meta_desc : Pp.formatted;
 }
 
+let print_meta_desc fmt m =
+  fprintf fmt "@[%s@\n  @[%a@]@]"
+    m.meta_name Pp.formatted m.meta_desc
+
 module SMmeta = StructMake(struct type t = meta let tag m = m.meta_tag end)
 
 module Smeta = SMmeta.S
@@ -124,24 +129,26 @@ let meta_table = Hashtbl.create 17
 
 let mk_meta =
   let c = ref (-1) in
-  fun s al excl -> {
+  fun desc s al excl -> {
     meta_name = s;
     meta_type = al;
     meta_excl = excl;
-    meta_tag  = (incr c; !c) }
+    meta_tag  = (incr c; !c);
+    meta_desc = desc;
+  }
 
-let register_meta s al excl =
+let register_meta ~desc s al excl =
   try
     let m = Hashtbl.find meta_table s in
     if al = m.meta_type && excl = m.meta_excl then m
     else raise (KnownMeta m)
   with Not_found ->
-    let m = mk_meta s al excl in
+    let m = mk_meta desc s al excl in
     Hashtbl.add meta_table s m;
     m
 
-let register_meta_excl s al = register_meta s al true
-let register_meta      s al = register_meta s al false
+let register_meta_excl ~desc s al = register_meta ~desc s al true
+let register_meta      ~desc s al = register_meta ~desc s al false
 
 let lookup_meta s =
   try Hashtbl.find meta_table s
@@ -149,6 +156,8 @@ let lookup_meta s =
 
 let list_metas () = Hashtbl.fold (fun _ v acc -> v::acc) meta_table []
 
+let set_meta_desc f m = m.meta_desc <- f
+
 (** Theory *)
 
 type theory = {

src/core/theory.mli

@@ -63,8 +63,11 @@ type meta = private {
   meta_type : meta_arg_type list;
   meta_excl : bool;
   meta_tag  : int;
+  mutable meta_desc : Pp.formatted;
 }
 
+val print_meta_desc : Pp.formatter -> meta -> unit
+
 module Mmeta : Map.S with type key = meta
 module Smeta : Mmeta.Set
 module Hmeta : Hashtbl.S with type key = meta
@@ -72,13 +75,16 @@ module Hmeta : Hashtbl.S with type key = meta
 val meta_equal : meta -> meta -> bool
 val meta_hash : meta -> int
 
-val register_meta      : string -> meta_arg_type list -> meta
-val register_meta_excl : string -> meta_arg_type list -> meta
+val register_meta      :
+  desc:Pp.formatted -> string -> meta_arg_type list -> meta
+val register_meta_excl :
+  desc:Pp.formatted -> string -> meta_arg_type list -> meta
 (** Register exclusive meta, each new setting remove the previous one.
 Useful for transformation or printer parameters *)
 
 val lookup_meta : string -> meta
 val list_metas  : unit -> meta list
+val set_meta_desc : Pp.formatted -> meta -> unit
 
 (** Theory *)
 

src/core/trans.ml

@@ -18,6 +18,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
+open Format
 open Util
 open Ident
 open Ty
@@ -27,6 +28,8 @@ open Theory
 open Task
 
 let debug = Debug.register_flag "transform"
+  ~desc:"About@ which@ transformations@ are@ applied@ and@ with@ which@ \
+         arguments, ie metas."
 
 (** Task transformation *)
 
@@ -255,33 +258,85 @@ let named s f (x : task) =
   if Debug.test_flag Debug.stack_trace then f x
   else try f x with e -> raise (TransFailure (s,e))
 
-let transforms   : (string, env -> task trans) Hashtbl.t = Hashtbl.create 17
-let transforms_l : (string, env -> task tlist) Hashtbl.t = Hashtbl.create 17
-
-let register_transform s p =
+type desc_labels = (label * Pp.formatted) list
+type desc_metas  = (meta  * Pp.formatted) list
+
+type reg_desc =
+ {
+   reg_desc_labels : desc_labels;
+   reg_desc_metas  : desc_metas;
+   reg_desc        : Pp.formatted;
+ }
+
+let print_reg_desc fmt r =
+  let print_meta fmt (m,f) =
+    fprintf fmt "@[%s@\n  @[%a%a@]@]"
+      m.meta_name Pp.formatted m.meta_desc Pp.formatted f in
+  let print_label fmt (l,f) =
+    fprintf fmt "@[%s@\n  @[%a@]@]"
+      l.lab_string Pp.formatted f in
+  fprintf fmt "@[@[%a@]%a%a@]"
+    Pp.formatted r.reg_desc
+    (Pp.print_list_delim
+       ~start:(Pp.constant_formatted "@\nlabels:@\n  @[")
+       ~stop:(Pp.constant_formatted "@]")
+       ~sep:Pp.newline
+       print_label) r.reg_desc_labels
+    (Pp.print_list_delim
+       ~start:(Pp.constant_formatted "@\nmetas:@\n  @[")
+       ~stop:(Pp.constant_formatted "@]")
+       ~sep:Pp.newline
+       print_meta) r.reg_desc_metas
+
+let print_trans_desc fmt (x,r) =
+  fprintf fmt "@[%s@\n  @[%a@]@]" x print_reg_desc r
+
+type 'a reg_trans = (env -> 'a trans) * reg_desc
+
+let mk_reg_trans ?(desc_labels=[]) ?(desc_metas=[]) ~desc f =
+  f, { reg_desc_labels = desc_labels;
+       reg_desc_metas  = desc_metas;
+       reg_desc        = desc}
+
+
+let transforms   : (string, task reg_trans) Hashtbl.t = Hashtbl.create 17
+let transforms_l : (string, task list reg_trans) Hashtbl.t = Hashtbl.create 17
+
+let register_transform ?desc_labels ?desc_metas ~desc s p =
   if Hashtbl.mem transforms s then raise (KnownTrans s);
-  Hashtbl.replace transforms s (fun _ -> named s p)
+  Hashtbl.replace transforms s
+    (mk_reg_trans ?desc_labels ?desc_metas ~desc (fun _ -> named s p))
 
-let register_transform_l s p =
+let register_transform_l ?desc_labels ?desc_metas ~desc s p =
   if Hashtbl.mem transforms_l s then raise (KnownTrans s);
-  Hashtbl.replace transforms_l s (fun _ -> named s p)
+  Hashtbl.replace transforms_l s
+    (mk_reg_trans ?desc_labels ?desc_metas ~desc (fun _ -> named s p))
 
-let register_env_transform s p =
+let register_env_transform ?desc_labels ?desc_metas ~desc s p =
   if Hashtbl.mem transforms s then raise (KnownTrans s);
-  Hashtbl.replace transforms s (Wenv.memoize 3 (fun e -> named s (p e)))
+  Hashtbl.replace transforms s
+    (mk_reg_trans ?desc_labels ?desc_metas ~desc
+       (Wenv.memoize 3 (fun e -> named s (p e))))
 
-let register_env_transform_l s p =
+let register_env_transform_l ?desc_labels ?desc_metas ~desc s p =
   if Hashtbl.mem transforms_l s then raise (KnownTrans s);
-  Hashtbl.replace transforms_l s (Wenv.memoize 3 (fun e -> named s (p e)))
+  Hashtbl.replace transforms_l s
+    (mk_reg_trans ?desc_labels ?desc_metas ~desc
+       (Wenv.memoize 3 (fun e -> named s (p e))))
 
 let lookup_transform s =
-  try Hashtbl.find transforms s with Not_found -> raise (UnknownTrans s)
+  try fst (Hashtbl.find transforms s)
+  with Not_found -> raise (UnknownTrans s)
 
 let lookup_transform_l s =
-  try Hashtbl.find transforms_l s with Not_found -> raise (UnknownTrans s)
+  try fst (Hashtbl.find transforms_l s)
+  with Not_found -> raise (UnknownTrans s)
+
+let list_transforms ()   = Hashtbl.fold (fun k r acc ->
+  (k,snd r)::acc) transforms []
 
-let list_transforms ()   = Hashtbl.fold (fun k _ acc -> k::acc) transforms []
-let list_transforms_l () = Hashtbl.fold (fun k _ acc -> k::acc) transforms_l []
+let list_transforms_l ()   = Hashtbl.fold
+  (fun k r acc -> (k,snd r)::acc) transforms_l []
 
 (** fast transform *)
 type gentrans =

src/core/trans.mli

@@ -113,17 +113,38 @@ exception TransFailure of string * exn
 exception UnknownTrans of string
 exception KnownTrans of string
 
-val register_env_transform   : string -> (Env.env -> task trans) -> unit
-val register_env_transform_l : string -> (Env.env -> task tlist) -> unit
-
-val register_transform   : string -> task trans -> unit
-val register_transform_l : string -> task tlist -> unit
+type desc_labels = (Ident.label * Pp.formatted) list
+type desc_metas  = (meta * Pp.formatted) list
+
+val register_env_transform   :