Source file touch.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
(** Touch-action utilities

    @see <https://tailwindcss.com/docs/touch-action>
      Tailwind CSS Touch Action documentation *)

module Css = Cascade.Css

module Handler = struct
  open Style
  open Css

  (* The ten values a [touch-*] class names, spelled as the utility's own type
     rather than as a [Css.touch_action]. A composed list, a CSS-wide keyword
     and a [var()] are all touch-action values and none of them is a utility, so
     carrying the CSS type here would leave [data] partial and [to_class]
     raising on a value it was handed. *)
  type t =
    | Auto
    | Manipulation
    | No_action
    | Pan_left
    | Pan_right
    | Pan_x
    | Pan_down
    | Pan_up
    | Pan_y
    | Pinch_zoom

  let name = "touch"

  (* Touch-action follows cursor and opens the shared interaction band. *)
  let priority _ = 11

  (* CSS Variables for composable touch-action values *)
  let tw_pan_x_var =
    Var.channel ~needs_property:true ~property_order:50 Touch_action "tw-pan-x"

  let tw_pan_y_var =
    Var.channel ~needs_property:true ~property_order:51 Touch_action "tw-pan-y"

  let tw_pinch_zoom_var =
    Var.channel ~needs_property:true ~property_order:52 Touch_action
      "tw-pinch-zoom"

  let touch_props =
    List.filter_map Var.property_rule
      [ tw_pan_x_var; tw_pan_y_var; tw_pinch_zoom_var ]
    |> concat

  (* Create a touch-action value that references all three vars with empty
     fallbacks *)
  let composable_touch_action () =
    let pan_x_ref = Var.reference_with_empty_fallback tw_pan_x_var in
    let pan_y_ref = Var.reference_with_empty_fallback tw_pan_y_var in
    let pinch_zoom_ref = Var.reference_with_empty_fallback tw_pinch_zoom_var in
    touch_action (Vars [ pan_x_ref; pan_y_ref; pinch_zoom_ref ])

  (* Helper for composable touch styles *)
  let composable_style var value =
    let decl = Var.set var value in
    style ~property_rules:touch_props [ decl; composable_touch_action () ]

  (* Class suffix and style of one utility. One match covers both, so a
     constructor added to [t] without an entry here is a compile error. *)
  let data : t -> string * Style.t = function
    | Auto -> ("auto", style [ touch_action Css.Auto ])
    | Manipulation -> ("manipulation", style [ touch_action Css.Manipulation ])
    | No_action -> ("none", style [ touch_action Css.None ])
    | Pan_left -> ("pan-left", composable_style tw_pan_x_var Css.Pan_left)
    | Pan_right -> ("pan-right", composable_style tw_pan_x_var Css.Pan_right)
    | Pan_x -> ("pan-x", composable_style tw_pan_x_var Css.Pan_x)
    | Pan_down -> ("pan-down", composable_style tw_pan_y_var Css.Pan_down)
    | Pan_up -> ("pan-up", composable_style tw_pan_y_var Css.Pan_up)
    | Pan_y -> ("pan-y", composable_style tw_pan_y_var Css.Pan_y)
    | Pinch_zoom ->
        ("pinch-zoom", composable_style tw_pinch_zoom_var Css.Pinch_zoom)

  (* Every value a class names, for the class-name lookup. *)
  let all =
    [
      Auto;
      Manipulation;
      No_action;
      Pan_left;
      Pan_right;
      Pan_x;
      Pan_down;
      Pan_up;
      Pan_y;
      Pinch_zoom;
    ]

  let to_class v =
    let suffix, _ = data v in
    "touch-" ^ suffix

  let to_style _theme v =
    let _, s = data v in
    s

  let suborder = function
    (* Composed values carry a second property-order key, so they precede the
       direct touch-action values. Candidate names settle ties within a key. *)
    | Pan_left | Pan_right | Pan_x -> 500_000
    | Pan_down | Pan_up | Pan_y -> 500_001
    | Pinch_zoom -> 500_002
    | Auto | Manipulation | No_action -> 500_003

  let of_class_map = List.map (fun v -> (to_class v, v)) all

  let of_class _theme cls =
    match List.assoc_opt cls of_class_map with
    | Some t -> Ok t
    | None -> Error (`Msg "Not a touch-action utility")

  let examples = [ Auto ]
end

open Handler
module Utility_factory = Utility.Make (Handler)

let utility = Utility_factory.v
let touch_auto = utility Auto
let touch_none = utility No_action
let touch_manipulation = utility Manipulation
let touch_pan_x = utility Pan_x
let touch_pan_y = utility Pan_y
let touch_pan_left = utility Pan_left
let touch_pan_right = utility Pan_right
let touch_pan_up = utility Pan_up
let touch_pan_down = utility Pan_down
let touch_pinch_zoom = utility Pinch_zoom