Commit 0793da2d authored by Guillaume Melquiond's avatar Guillaume Melquiond

Turn Args_wrapper.print_type into a printing function.

parent 6b7621bf
......@@ -381,29 +381,29 @@ let rec string_of_trans_typ : type a b. (a, b) trans_typ -> string =
| Topt (s,t) -> "?" ^ s ^ (string_of_trans_typ t)
| Toptbool (s,_) -> "?" ^ s ^ ":bool"
let rec print_type : type a b. (a, b) trans_typ -> string =
fun t ->
let rec print_type : type a b. Format.formatter -> (a, b) trans_typ -> unit =
fun fmt t ->
match t with
| Ttrans -> "task"
| Ttrans_l -> "list task"
| Tenvtrans -> "env -> task"
| Tenvtrans_l -> "env -> list task"
| Tint t -> "integer -> " ^ print_type t
| Tstring t -> "string -> " ^ print_type t
| Tty t -> "type -> " ^ print_type t
| Ttysymbol t -> "type_symbol -> " ^ print_type t
| Tprsymbol t -> "prsymbol -> " ^ print_type t
| Tprlist t -> "list prsymbol -> " ^ print_type t
| Tlsymbol t -> "lsymbol -> " ^ print_type t
| Tsymbol t -> "symbol -> " ^ print_type t
| Tlist t -> "list symbol -> " ^ print_type t
| Tterm t -> "term -> " ^ print_type t
| Tformula t -> "formula -> " ^ print_type t
| Tidentlist t -> "list ident -> " ^ print_type t
| Ttermlist t -> "list term -> " ^ print_type t
| Ttheory t -> "theory -> " ^ print_type t
| Topt (s,t) -> "?" ^ s ^ ":" ^ print_type t
| Toptbool (s,t) -> "?" ^ s ^ ":bool -> " ^ print_type t
| Ttrans -> Format.fprintf fmt "task"
| Ttrans_l -> Format.fprintf fmt "list task"
| Tenvtrans -> Format.fprintf fmt "env -> task"
| Tenvtrans_l -> Format.fprintf fmt "env -> list task"
| Tint t -> Format.fprintf fmt "integer -> %a" print_type t
| Tstring t -> Format.fprintf fmt "string -> %a" print_type t
| Tty t -> Format.fprintf fmt "type -> %a" print_type t
| Ttysymbol t -> Format.fprintf fmt "type_symbol -> %a" print_type t
| Tprsymbol t -> Format.fprintf fmt "prsymbol -> %a" print_type t
| Tprlist t -> Format.fprintf fmt "list prsymbol -> %a" print_type t
| Tlsymbol t -> Format.fprintf fmt "lsymbol -> %a" print_type t
| Tsymbol t -> Format.fprintf fmt "symbol -> %a" print_type t
| Tlist t -> Format.fprintf fmt "list symbol -> %a" print_type t
| Tterm t -> Format.fprintf fmt "term -> %a" print_type t
| Tformula t -> Format.fprintf fmt "formula -> %a" print_type t
| Tidentlist t -> Format.fprintf fmt "list ident -> %a" print_type t
| Ttermlist t -> Format.fprintf fmt "list term -> %a" print_type t
| Ttheory t -> Format.fprintf fmt "theory -> %a" print_type t
| Topt (s,t) -> Format.fprintf fmt "?%s -> %a" s print_type t
| Toptbool (s,t) -> Format.fprintf fmt "?%s:bool -> %a" s print_type t
exception Unnecessary_arguments of string list
......@@ -528,15 +528,20 @@ let wrap_any : type a b. (a, b) trans_typ -> a -> string list -> Env.env ->
Trans.naming_table -> b trans =
fun t f l env tables -> Trans.store (wrap_to_store t f l env tables)
(* the one in Scanf is awfully broken with respect to backslashes *)
let format_from_string s fmt =
Scanf.sscanf_format (Printf.sprintf "%S" s) fmt (fun s -> s)
let wrap_and_register : type a b. desc:Pp.formatted -> string -> (a, b) trans_typ -> a -> unit =
fun ~desc name t f ->
let type_desc = Scanf.format_from_string ("type : " ^ print_type t ^ "\n") Pp.empty_formatted in
(* "%@\n" is escaped on purpose *)
let type_desc = Format.asprintf "type: %a%@\n" print_type t in
let type_desc = format_from_string type_desc Pp.empty_formatted in
let desc = type_desc ^^ desc in
let trans = wrap_any t f in
match is_trans_typ_l t with
| Yes ->
Trans.register_transform_with_args_l ~desc:(type_desc ^^ desc) name trans
| No ->
Trans.register_transform_with_args ~desc:(type_desc ^^ desc) name trans
| Yes -> Trans.register_transform_with_args_l ~desc name trans
| No -> Trans.register_transform_with_args ~desc name trans
let find_symbol s tables = find_symbol (parse_qualid s) tables
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment