Source file reason_attributes.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
open Ppxlib

type attributesPartition =
  { arityAttrs : attributes
  ; docAttrs : attributes
  ; stdAttrs : attributes
  ; jsxAttrs : attributes
  ; stylisticAttrs : attributes
  ; uncurried : bool
  }
(** Kinds of attributes *)

(** Partition attributes into kinds *)
let rec partitionAttributes ?(partDoc = false) ?(allowUncurry = true) attrs :
  attributesPartition
  =
  match attrs with
  | [] ->
    { arityAttrs = []
    ; docAttrs = []
    ; stdAttrs = []
    ; jsxAttrs = []
    ; stylisticAttrs = []
    ; uncurried = false
    }
  | ({ attr_name = { txt = "u" | "bs"; _ }; attr_payload = PStr []; _ } as attr)
    :: atTl ->
    let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
    if allowUncurry
    then { partition with uncurried = true }
    else { partition with stdAttrs = attr :: partition.stdAttrs }
  | ({ attr_name = { txt = "JSX"; _ }; _ } as jsx) :: atTl ->
    let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
    { partition with jsxAttrs = jsx :: partition.jsxAttrs }
  | ({ attr_name = { txt = "explicit_arity"; _ }; _ } as arity_attr) :: atTl
  | ({ attr_name = { txt = "implicit_arity"; _ }; _ } as arity_attr) :: atTl ->
    let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
    { partition with arityAttrs = arity_attr :: partition.arityAttrs }
  | ({ attr_name = { txt = "ocaml.text"; _ }; _ } as doc) :: atTl
    when partDoc = true ->
    let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
    { partition with docAttrs = doc :: partition.docAttrs }
  | ({ attr_name = { txt = "ocaml.doc" | "ocaml.text"; _ }; _ } as doc) :: atTl
    when partDoc = true ->
    let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
    { partition with docAttrs = doc :: partition.docAttrs }
  | ({ attr_name = { txt = "reason.raw_literal"; _ }; _ } as attr) :: atTl ->
    let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
    { partition with stylisticAttrs = attr :: partition.stylisticAttrs }
  | ({ attr_name = { txt = "reason.preserve_braces"; _ }; _ } as attr) :: atTl
    ->
    let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
    { partition with stylisticAttrs = attr :: partition.stylisticAttrs }
  | ({ attr_name = { txt = "reason.openSyntaxNotation"; _ }; _ } as attr)
    :: atTl ->
    let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
    { partition with stylisticAttrs = attr :: partition.stylisticAttrs }
  | ({ attr_name = { txt = "reason.quoted_extension"; _ }; _ } as attr) :: atTl
    ->
    let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
    { partition with stylisticAttrs = attr :: partition.stylisticAttrs }
  | atHd :: atTl ->
    let partition = partitionAttributes ~partDoc ~allowUncurry atTl in
    { partition with stdAttrs = atHd :: partition.stdAttrs }

let extractStdAttrs attrs = (partitionAttributes attrs).stdAttrs

let extract_raw_literal attrs =
  let rec loop acc = function
    | { attr_name = { txt = "reason.raw_literal"; _ }
      ; attr_payload =
          PStr
            [ { pstr_desc =
                  Pstr_eval
                    ( { pexp_desc = Pexp_constant (Pconst_string (text, _, None))
                      ; _
                      }
                    , _ )
              ; _
              }
            ]
      ; _
      }
      :: rest ->
      Some text, List.rev_append acc rest
    | [] -> None, List.rev acc
    | attr :: rest -> loop (attr :: acc) rest
  in
  loop [] attrs

let without_stylistic_attrs attrs =
  let rec loop acc = function
    | attr :: rest when (partitionAttributes [ attr ]).stylisticAttrs != [] ->
      loop acc rest
    | [] -> List.rev acc
    | attr :: rest -> loop (attr :: acc) rest
  in
  loop [] attrs

(* TODO: Make this fast and not filter *)
let has_jsx_attributes =
  let is_jsx_attribute { attr_name = { txt; _ }; _ } = txt = "JSX" in
  fun attrs -> List.exists is_jsx_attribute attrs

let has_preserve_braces_attrs =
  let is_preserve_braces_attr { attr_name = { txt; _ }; _ } =
    txt = "reason.preserve_braces"
  in
  fun stylisticAttrs -> List.exists is_preserve_braces_attr stylisticAttrs

let has_quoted_extension_attrs =
  let is_quoted_extension_attr { attr_name = { txt; _ }; _ } =
    txt = "reason.quoted_extension"
  in
  fun stylisticAttrs -> List.exists is_quoted_extension_attr stylisticAttrs

let maybe_remove_stylistic_attrs attrs ~should_preserve =
  if should_preserve
  then attrs
  else
    List.filter
      (function
        | { attr_name = { txt = "reason.raw_literal"; _ }; _ } -> true
        | _ -> false)
      attrs

let has_open_notation_attr =
  let is_open_notation_attr { attr_name = { txt; _ }; _ } =
    txt = "reason.openSyntaxNotation"
  in
  fun stylisticAttrs -> List.exists is_open_notation_attr stylisticAttrs