Source file styles_attribute.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
let is_jsx_attribute { Ppxlib.attr_name; _ } = attr_name.txt = "JSX"
let has_jsx_attribute apply_expr = List.exists is_jsx_attribute apply_expr.Ppxlib.pexp_attributes
let is_lowercase_name name = String.length name > 0 && match name.[0] with 'a' .. 'z' -> true | _ -> false

let is_lowercase_html_tag_call (fn : Ppxlib.expression) =
  match fn.pexp_desc with Pexp_ident { txt = Lident name; _ } -> is_lowercase_name name | _ -> false

let should_expand_apply (apply_expr : Ppxlib.expression) =
  match apply_expr.pexp_desc with
  | Pexp_apply (fn, _) -> has_jsx_attribute apply_expr && is_lowercase_html_tag_call fn
  | _ -> false

let expand_attributes ~loc attributes =
  let merge_className current_className (label, expr) =
    match current_className with
    | Some (existing_label, existing_expr) ->
        let merged =
          match label with
          | Ppxlib.Optional "className" ->
              [%expr match [%e expr] with None -> [%e existing_expr] | Some x -> x ^ " " ^ [%e existing_expr]]
          | _ -> [%expr [%e expr] ^ " " ^ [%e existing_expr]]
        in
        Some (existing_label, merged)
    | None -> Some (label, expr)
  in
  let merge_style current_style (label, expr) =
    match current_style with
    | Some (existing_label, existing_expr) ->
        let merged =
          match label with
          | Ppxlib.Optional "style" ->
              [%expr
                match [%e expr] with
                | None -> [%e existing_expr]
                | Some x -> ReactDOM.Style.combine [%e existing_expr] x]
          | _ -> [%expr ReactDOM.Style.combine [%e existing_expr] [%e expr]]
        in
        Some (existing_label, merged)
    | None -> Some (label, expr)
  in
  let handle_styles className style label arg =
    let className_label, className_expr, style_label, style_expr =
      match label with
      | Ppxlib.Labelled "styles" ->
          (Ppxlib.Labelled "className", [%expr fst [%e arg]], Ppxlib.Labelled "style", [%expr snd [%e arg]])
      | _ ->
          ( Ppxlib.Optional "className",
            [%expr match [%e arg] with None -> None | Some x -> Some (fst x)],
            Ppxlib.Optional "style",
            [%expr match [%e arg] with None -> None | Some x -> Some (snd x)] )
    in
    (merge_className className (className_label, className_expr), merge_style style (style_label, style_expr))
  in
  let rec aux (className, style, other_args) args =
    match args with
    | [] -> (
        let rest = List.rev other_args in
        match (className, style) with
        | Some c, Some s -> c :: s :: rest
        | Some c, None -> c :: rest
        | None, Some s -> s :: rest
        | None, None -> rest)
    | (label, arg) :: rest -> (
        match label with
        | Ppxlib.Labelled "className" | Ppxlib.Optional "className" ->
            aux (merge_className className (label, arg), style, other_args) rest
        | Ppxlib.Labelled "style" | Ppxlib.Optional "style" ->
            aux (className, merge_style style (label, arg), other_args) rest
        | Ppxlib.Labelled "styles" | Ppxlib.Optional "styles" ->
            let new_className, new_style = handle_styles className style label arg in
            aux (new_className, new_style, other_args) rest
        | _ -> aux (className, style, (label, arg) :: other_args) rest)
  in
  aux (None, None, []) attributes

let expand (expr : Ppxlib.expression) =
  match expr.pexp_desc with
  | Pexp_apply (({ pexp_loc = loc; _ } as tag), attributes) when should_expand_apply expr ->
      let new_attributes = expand_attributes ~loc attributes in
      { expr with pexp_desc = Pexp_apply (tag, new_attributes) }
  | _ -> expr