package ppx_deriving
Type-driven code generation for OCaml
Install
Dune Dependency
Authors
Maintainers
Sources
ppx_deriving-v5.2.tbz
sha256=1c2d2626824ca350c365bf6c8bc3a23c8045c3995c170f2bc500e53baeda2ee6
sha512=03ce8b3a0d8ed56b6c078212ac54862d99e4296c0e31cc982f9e632bae973a955207cfa968dbcd9d88aa444addda557556f549ef926ae7196534f9b7c007cf10
doc/src/ppx_deriving_show/ppx_deriving_show.ml.html
Source file ppx_deriving_show.ml
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331
# 1 "ppx_deriving_show.cppo.ml" open Ppxlib open Asttypes open Parsetree open Ast_helper open Ppx_deriving.Ast_convenience let deriver = "show" let raise_errorf = Ppx_deriving.raise_errorf type options = { with_path : bool } (* The option [with_path] controls whether a full path should be displayed as part of data constructor names and record field names. (In the case of record fields, it is displayed only as part of the name of the first field.) By default, this option is [true], which means that full paths are shown. *) let expand_path show_opts ~path name = let path = if show_opts.with_path then path else [] in Ppx_deriving.expand_path ~path name let parse_options options = let with_path = ref true in options |> List.iter (fun (name, expr) -> match name with | "with_path" -> with_path := Ppx_deriving.Arg.(get_expr ~deriver bool) expr | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name); { with_path = !with_path } let attr_nobuiltin attrs = Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) let attr_printer attrs = Ppx_deriving.(attrs |> attr ~deriver "printer" |> Arg.(get_attr ~deriver expr)) let attr_polyprinter attrs = Ppx_deriving.(attrs |> attr ~deriver "polyprinter" |> Arg.(get_attr ~deriver expr)) let attr_opaque attrs = Ppx_deriving.(attrs |> attr ~deriver "opaque" |> Arg.get_flag ~deriver) let argn = Printf.sprintf "a%d" let argl = Printf.sprintf "a%s" let pattn typs = List.mapi (fun i _ -> pvar (argn i)) typs let pattl labels = List.map (fun { pld_name = { txt = n } } -> n, pvar (argl n)) labels let pconstrrec name fields = pconstr name [precord ~closed:Closed fields] let wrap_printer quoter printer = let loc = !Ast_helper.default_loc in Ppx_deriving.quote ~quoter [%expr (let fprintf = Ppx_deriving_runtime.Format.fprintf in [%e printer]) [@ocaml.warning "-26"]] let pp_type_of_decl ~options ~path type_decl = let loc = type_decl.ptype_loc in let _ = parse_options options in let typ = Ppx_deriving.core_type_of_type_decl type_decl in Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: Ppx_deriving_runtime.Format.formatter -> [%t var] -> Ppx_deriving_runtime.unit]) type_decl [%type: Ppx_deriving_runtime.Format.formatter -> [%t typ] -> Ppx_deriving_runtime.unit] let show_type_of_decl ~options ~path type_decl = let loc = type_decl.ptype_loc in let _ = parse_options options in let typ = Ppx_deriving.core_type_of_type_decl type_decl in Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: Ppx_deriving_runtime.Format.formatter -> [%t var] -> Ppx_deriving_runtime.unit]) type_decl [%type: [%t typ] -> Ppx_deriving_runtime.string] let sig_of_type ~options ~path type_decl = let _ = parse_options options in [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl)) (pp_type_of_decl ~options ~path type_decl)); Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "show") type_decl)) (show_type_of_decl ~options ~path type_decl))] let rec expr_of_typ quoter typ = let loc = typ.ptyp_loc in let expr_of_typ = expr_of_typ quoter in match attr_printer typ.ptyp_attributes with | Some printer -> [%expr [%e wrap_printer quoter printer] fmt] | None -> if attr_opaque typ.ptyp_attributes then [%expr fun _ -> Ppx_deriving_runtime.Format.pp_print_string fmt "<opaque>"] else let format x = [%expr Ppx_deriving_runtime.Format.fprintf fmt [%e str x]] in let seq start finish fold typ = [%expr fun x -> Ppx_deriving_runtime.Format.fprintf fmt [%e str start]; ignore ([%e fold] (fun sep x -> if sep then Ppx_deriving_runtime.Format.fprintf fmt ";@ "; [%e expr_of_typ typ] x; true) false x); Ppx_deriving_runtime.Format.fprintf fmt [%e str finish];] in let typ = Ppx_deriving.remove_pervasives ~deriver typ in match typ with | [%type: _] -> [%expr fun _ -> Ppx_deriving_runtime.Format.pp_print_string fmt "_"] | { ptyp_desc = Ptyp_arrow _ } -> [%expr fun _ -> Ppx_deriving_runtime.Format.pp_print_string fmt "<fun>"] | { ptyp_desc = Ptyp_constr _ } -> let builtin = not (attr_nobuiltin typ.ptyp_attributes) in begin match builtin, typ with | true, [%type: unit] -> [%expr fun () -> Ppx_deriving_runtime.Format.pp_print_string fmt "()"] | true, [%type: int] -> format "%d" | true, [%type: int32] | true, [%type: Int32.t] -> format "%ldl" | true, [%type: int64] | true, [%type: Int64.t] -> format "%LdL" | true, [%type: nativeint] | true, [%type: Nativeint.t] -> format "%ndn" | true, [%type: float] -> format "%F" | true, [%type: bool] -> format "%B" | true, [%type: char] -> format "%C" | true, [%type: string] | true, [%type: String.t] -> format "%S" | true, [%type: bytes] | true, [%type: Bytes.t] -> [%expr fun x -> Ppx_deriving_runtime.Format.fprintf fmt "%S" (Bytes.to_string x)] | true, [%type: [%t? typ] ref] -> [%expr fun x -> Ppx_deriving_runtime.Format.pp_print_string fmt "ref ("; [%e expr_of_typ typ] !x; Ppx_deriving_runtime.Format.pp_print_string fmt ")"] | true, [%type: [%t? typ] list] -> seq "@[<2>[" "@,]@]" [%expr List.fold_left] typ | true, [%type: [%t? typ] array] -> seq "@[<2>[|" "@,|]@]" [%expr Array.fold_left] typ | true, [%type: [%t? typ] option] -> [%expr function | None -> Ppx_deriving_runtime.Format.pp_print_string fmt "None" | Some x -> Ppx_deriving_runtime.Format.pp_print_string fmt "(Some "; [%e expr_of_typ typ] x; Ppx_deriving_runtime.Format.pp_print_string fmt ")"] | true, ([%type: ([%t? ok_t], [%t? err_t]) result] | [%type: ([%t? ok_t], [%t? err_t]) Result.result]) -> [%expr function | Result.Ok ok -> Ppx_deriving_runtime.Format.pp_print_string fmt "(Ok "; [%e expr_of_typ ok_t] ok; Ppx_deriving_runtime.Format.pp_print_string fmt ")" | Result.Error e -> Ppx_deriving_runtime.Format.pp_print_string fmt "(Error "; [%e expr_of_typ err_t] e; Ppx_deriving_runtime.Format.pp_print_string fmt ")"] | true, ([%type: [%t? typ] lazy_t] | [%type: [%t? typ] Lazy.t]) -> [%expr fun x -> if Lazy.is_val x then [%e expr_of_typ typ] (Lazy.force x) else Ppx_deriving_runtime.Format.pp_print_string fmt "<not evaluated>"] | _, { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> let args_pp = List.map (fun typ -> [%expr fun fmt -> [%e expr_of_typ typ]]) args in let printer = match attr_polyprinter typ.ptyp_attributes with | Some printer -> wrap_printer quoter printer | None -> let printer = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Prefix "pp") lid)) in Ppx_deriving.quote ~quoter printer in app printer (args_pp @ [[%expr fmt]]) | _ -> assert false end | { ptyp_desc = Ptyp_tuple typs } -> let args = List.mapi (fun i typ -> app (expr_of_typ typ) [evar (argn i)]) typs in [%expr fun [%p ptuple (List.mapi (fun i _ -> pvar (argn i)) typs)] -> Ppx_deriving_runtime.Format.fprintf fmt "(@["; [%e args |> Ppx_deriving.(fold_exprs (seq_reduce ~sep:[%expr Ppx_deriving_runtime.Format.fprintf fmt ",@ "]))]; Ppx_deriving_runtime.Format.fprintf fmt "@])"] | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } -> let cases = fields |> List.map (fun field -> match field.prf_desc with | Rtag(label, true (*empty*), []) -> let label = label.txt in Exp.case (Pat.variant label None) [%expr Ppx_deriving_runtime.Format.pp_print_string fmt [%e str ("`" ^ label)]] | Rtag(label, false, [typ]) -> let label = label.txt in Exp.case (Pat.variant label (Some [%pat? x])) [%expr Ppx_deriving_runtime.Format.fprintf fmt [%e str ("`" ^ label ^ " (@[<hov>")]; [%e expr_of_typ typ] x; Ppx_deriving_runtime.Format.fprintf fmt "@])"] | Rinherit({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> Exp.case [%pat? [%p Pat.type_ tname] as x] [%expr [%e expr_of_typ typ] x] | _ -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ)) in Exp.function_ cases | { ptyp_desc = Ptyp_var name } -> [%expr [%e evar ("poly_"^name)] fmt] | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ typ | { ptyp_loc } -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ) and expr_of_label_decl quoter { pld_type; pld_attributes } = let attrs = pld_type.ptyp_attributes @ pld_attributes in expr_of_typ quoter { pld_type with ptyp_attributes = attrs } let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = let show_opts = parse_options options in let quoter = Ppx_deriving.create_quoter () in let path = Ppx_deriving.path_of_type_decl ~path type_decl in let prettyprinter = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_abstract, Some manifest -> [%expr fun fmt -> [%e expr_of_typ quoter manifest]] | Ptype_variant constrs, _ -> let cases = constrs |> List.map (fun { pcd_name = { txt = name' }; pcd_args; pcd_attributes } -> let constr_name = expand_path show_opts ~path name' in match attr_printer pcd_attributes, pcd_args with | Some printer, Pcstr_tuple(args) -> let rec range from_idx to_idx = if from_idx = to_idx then [] else from_idx::(range (from_idx+1) to_idx) in let indices = range 0 (List.length args) in let pattern_vars = List.map (fun i -> pvar ("a" ^ string_of_int i)) indices in let expr_vars = List.map (fun i -> evar ("a" ^ string_of_int i)) indices in Exp.case (pconstr name' pattern_vars) [%expr [%e wrap_printer quoter printer] fmt [%e tuple expr_vars]] | Some printer, Pcstr_record(labels) -> let args = labels |> List.map (fun { pld_name = { txt = n } } -> evar (argl n)) in Exp.case (pconstrrec name' (pattl labels)) (app (wrap_printer quoter printer) ([%expr fmt] :: args)) | None, Pcstr_tuple(typs) -> let args = List.mapi (fun i typ -> app (expr_of_typ quoter typ) [evar (argn i)]) typs in let printer = match args with | [] -> [%expr Ppx_deriving_runtime.Format.pp_print_string fmt [%e str constr_name]] | [arg] -> [%expr Ppx_deriving_runtime.Format.fprintf fmt [%e str ("(@[<2>" ^ constr_name ^ "@ ")]; [%e arg]; Ppx_deriving_runtime.Format.fprintf fmt "@])"] | args -> [%expr Ppx_deriving_runtime.Format.fprintf fmt [%e str ("(@[<2>" ^ constr_name ^ " (@,")]; [%e args |> Ppx_deriving.(fold_exprs (seq_reduce ~sep:[%expr Ppx_deriving_runtime.Format.fprintf fmt ",@ "]))]; Ppx_deriving_runtime.Format.fprintf fmt "@,))@]"] in Exp.case (pconstr name' (pattn typs)) printer | None, Pcstr_record(labels) -> let args = labels |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) -> [%expr Ppx_deriving_runtime.Format.fprintf fmt "@[%s =@ " [%e str n]; [%e expr_of_label_decl quoter pld] [%e evar (argl n)]; Ppx_deriving_runtime.Format.fprintf fmt "@]" ]) in let printer = [%expr Ppx_deriving_runtime.Format.fprintf fmt [%e str ("@[<2>" ^ constr_name ^ " {@,")]; [%e args |> Ppx_deriving.(fold_exprs (seq_reduce ~sep:[%expr Ppx_deriving_runtime.Format.fprintf fmt ";@ "]))]; Ppx_deriving_runtime.Format.fprintf fmt "@]}"] in Exp.case (pconstrrec name' (pattl labels)) printer ) in [%expr fun fmt -> [%e Exp.function_ cases]] | Ptype_record labels, _ -> let fields = labels |> List.mapi (fun i ({ pld_name = { txt = name }; _} as pld) -> let field_name = if i = 0 then expand_path show_opts ~path name else name in [%expr Ppx_deriving_runtime.Format.fprintf fmt "@[%s =@ " [%e str field_name]; [%e expr_of_label_decl quoter pld] [%e Exp.field (evar "x") (mknoloc (Lident name))]; Ppx_deriving_runtime.Format.fprintf fmt "@]" ]) in [%expr fun fmt x -> Ppx_deriving_runtime.Format.fprintf fmt "@[<2>{ "; [%e fields |> Ppx_deriving.(fold_exprs (seq_reduce ~sep:[%expr Ppx_deriving_runtime.Format.fprintf fmt ";@ "]))]; Ppx_deriving_runtime.Format.fprintf fmt "@ }@]"] | Ptype_abstract, None -> raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver | Ptype_open, _ -> raise_errorf ~loc "%s cannot be derived for open types" deriver in let pp_poly_apply = Ppx_deriving.poly_apply_of_type_decl type_decl (evar (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl)) in let stringprinter = [%expr fun x -> Ppx_deriving_runtime.Format.asprintf "%a" [%e pp_poly_apply] x] in let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in let pp_type = Ppx_deriving.strong_type_of_type @@ pp_type_of_decl ~options ~path type_decl in let show_type = Ppx_deriving.strong_type_of_type @@ show_type_of_decl ~options ~path type_decl in let pp_var = pvar (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl) in let show_var = pvar (Ppx_deriving.mangle_type_decl (`Prefix "show") type_decl) in let no_warn_32 = Ppx_deriving.attr_warning [%expr "-32"] in [Vb.mk (Pat.constraint_ pp_var pp_type) (Ppx_deriving.sanitize ~quoter (polymorphize prettyprinter)); Vb.mk ~attrs:[no_warn_32] (Pat.constraint_ show_var show_type) (polymorphize stringprinter);] let () = let loc = !Ast_helper.default_loc in Ppx_deriving.(register (create deriver ~core_type: (Ppx_deriving.with_quoter (fun quoter typ -> [%expr fun x -> Ppx_deriving_runtime.Format.asprintf "%a" (fun fmt -> [%e expr_of_typ quoter typ]) x])) ~type_decl_str: (fun ~options ~path type_decls -> [Str.value Recursive (List.concat (List.map (str_of_type ~options ~path) type_decls))]) ~type_decl_sig: (fun ~options ~path type_decls -> List.concat (List.map (sig_of_type ~options ~path) type_decls)) () ))
sectionYPositions = computeSectionYPositions($el), 10)"
x-init="setTimeout(() => sectionYPositions = computeSectionYPositions($el), 10)"
>