package ppx_mica

  1. Overview
  2. Docs

Source file printers.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
open Ppxlib
open StdLabels
open Astlib.Pprintast

(** {1 Pretty-printers} *)

(** List of OCaml base types 
    - The named argument [loc] is necessary in order for 
    the [Ppxlib.Metaquot] quotations to expand to the appropriate 
    AST fragments representing the base types. *)
let base_types ~(loc : Location.t) : core_type list =
  [ [%type: int];
    [%type: int32];
    [%type: int64];
    [%type: nativeint];
    [%type: char];
    [%type: bool];
    [%type: unit];
    [%type: float];
    [%type: string]
  ]

(** Alias for [Format.err_formatter] *)
let err_fmt : Format.formatter = Format.err_formatter

(** Pretty-printer for [pattern]s *)
let pp_pattern : pattern -> unit = pattern err_fmt

(** Pretty-printer for [core_type]s *)
let pp_core_type : core_type -> unit = core_type err_fmt

(** Pretty-printer for [expression]s *)
let pp_expression : expression -> unit = expression err_fmt

(** Pretty-printer for [structure_item]s *)
let pp_structure_item : structure_item -> unit = structure_item err_fmt

(** Instantiates all type variables ['a] inside a type expression with [int] 
  by recursing over the structure of the type expression. 
  Base types are left unchanged. 
  Note: this function only recurses over type expressions when 
  they consist of:
  - Type constructor applications ([Ptyp_constr])
  - Tuples ([Ptyp_tuple])
  - Arrow/function types ([Ptyp_arrow]). *)
let rec monomorphize (ty : core_type) : core_type =
  let loc = ty.ptyp_loc in
  match ty.ptyp_desc with
  | _ty_desc when List.mem ty ~set:(base_types ~loc) -> ty
  | Ptyp_var _ -> [%type: int]
  | Ptyp_arrow (arg_lbl, t1, t2) ->
    { ty with
      ptyp_desc = Ptyp_arrow (arg_lbl, monomorphize t1, monomorphize t2)
    }
  | Ptyp_tuple tys ->
    { ty with ptyp_desc = Ptyp_tuple (List.map ~f:monomorphize tys) }
  | Ptyp_constr (ident, ty_params) ->
    { ty with
      ptyp_desc = Ptyp_constr (ident, List.map ~f:monomorphize ty_params)
    }
  | _ -> ty

(** Converts a type expression [ty] to its capitalized, camel-case 
    string representation (for use as a constructor in an algebraic data type) 
    - The type expression is monomorphized prior to computing its string
    representation (i.e. ['a] is instantiated to [int]).
    - Note: polymoprhic variants, objects, extensions/attributes are 
    not supported by this function.  
    - Note: this function is slightly different from [Ppxlib.string_of_core_type]
    due to its capitalization, camel-case & monomorphization functionalities. *)
let rec string_of_monomorphized_ty (ty : core_type) : string =
  match ty.ptyp_desc with
  | Ptyp_var _ | Ptyp_any -> string_of_monomorphized_ty (monomorphize ty)
  | Ptyp_constr ({ txt = ident; _ }, ty_params) ->
    let ty_constr_str =
      Astlib.Longident.flatten ident
      |> String.concat ~sep:"" |> String.capitalize_ascii in
    let params_str =
      String.concat ~sep:"" (List.map ~f:string_of_monomorphized_ty ty_params)
    in
    params_str ^ ty_constr_str
  | Ptyp_tuple tys ->
    let ty_strs =
      List.map tys ~f:(fun ty ->
          string_of_monomorphized_ty ty |> String.capitalize_ascii) in
    String.concat ~sep:"" ty_strs ^ "Product"
  | Ptyp_arrow (_, t1, t2) ->
    string_of_monomorphized_ty t1 ^ string_of_monomorphized_ty t2
  | _ -> failwith "type expression not supported by string_of_monomorphized_ty"

(** Retrieves the name of a type as a snake-case string 
    - e.g. [int list] becomes ["int_list"] *)
let snake_case_type_name (ty : core_type) : string =
  Base.String.tr ~target:' ' ~replacement:'_' (Ppxlib.string_of_core_type ty)