Source file interactivity.ml

(** Interactivity utilities for selection, scroll behavior, and more

    What's included:
    - Text selection, scroll behavior, scroll snap, resize.

    What's not:
    - Browser-specific interaction properties not surfaced in `Css`.
    - Cursor utilities (now in Cursor module).

    Parsing contract (`of_string`):
    - Accepts tokens like ["select"; "none"], ["scroll"; "smooth"],
      ["snap"; "x"], ["resize"; "y"], etc. Unknown tokens yield `Error (`Msg
      "Not an interactivity utility")`. *)

module Css = Cascade.Css

module Handler = struct
  open Style
  open Css

  let err_not_utility = Error (`Msg "Not an interactivity utility")

  type t =
    | Select_none
    | Select_text
    | Select_all
    | Select_auto
    | Scroll_auto
    | Scroll_smooth
    | Snap_start
    | Snap_end
    | Snap_center
    | Snap_none
    | Snap_x
    | Snap_y
    | Snap_both
    | Snap_mandatory
    | Snap_proximity
    | Snap_align_none
    | Snap_normal
    | Snap_always
    | Resize_none
    | Resize
    | Resize_x
    | Resize_y
    | Pointer_events_none
    | Pointer_events_auto
    | Appearance_auto
    | Appearance_none
    | Will_change_auto
    | Will_change_scroll
    | Will_change_contents
    | Will_change_transform
    | Will_change_arbitrary of string
    | Group  (** Marker class for group parent *)
    | Peer  (** Marker class for peer sibling *)
    | Scheme_dark
    | Scheme_light
    | Scheme_light_dark
    | Scheme_normal
    | Scheme_only_dark
    | Scheme_only_light

  let name = "interactivity"

  (* Interaction controls from resize through appearance share priority 11 so
     they can sit between cursor and columns. Scroll behavior follows overflow
     and overscroll at priority 18; user-select and will-change sort late. *)
  let priority = function
    | Resize | Resize_none | Resize_x | Resize_y | Appearance_auto
    | Appearance_none | Snap_start | Snap_end | Snap_center | Snap_none | Snap_x
    | Snap_y | Snap_both | Snap_mandatory | Snap_proximity | Snap_align_none
    | Snap_normal | Snap_always ->
        11
    | Scroll_auto | Scroll_smooth -> 18
    | Scheme_dark | Scheme_light | Scheme_light_dark | Scheme_normal
    | Scheme_only_dark | Scheme_only_light ->
        27
    | Will_change_auto | Will_change_scroll | Will_change_contents
    | Will_change_transform | Will_change_arbitrary _ ->
        33
    | Select_none | Select_text | Select_all | Select_auto -> 38
    (* Tailwind's utility order opens with the container utilities and then
       pointer-events, before the layout group. *)
    | Pointer_events_none | Pointer_events_auto -> -1
    | _ -> 31

  let select_none_s = style [ webkit_user_select None; user_select None ]
  let select_text_s = style [ webkit_user_select Text; user_select Text ]
  let select_all_s = style [ webkit_user_select All; user_select All ]
  let select_auto_s = style [ webkit_user_select Auto; user_select Auto ]
  let scroll_auto_s = style [ scroll_behavior Auto ]
  let scroll_smooth_s = style [ scroll_behavior Smooth ]

  (* Reference to the global scroll snap strictness variable *)
  let scroll_snap_strictness_var =
    Var.property_default Css.Scroll_snap_strictness ~initial:Proximity
      ~property_order:90 "tw-scroll-snap-strictness"

  let snap_start_s = style [ scroll_snap_align Start ]
  let snap_end_s = style [ scroll_snap_align End ]
  let snap_center_s = style [ scroll_snap_align Center ]
  let snap_none_s = style [ scroll_snap_type (Axis None) ]

  (* For snap-x, snap-y, snap-both we compose the axis with a variable reference
     to strictness *)
  let snap_x_s =
    let ref_ = Var.reference scroll_snap_strictness_var in
    let property_rules = Var.property_rules scroll_snap_strictness_var in
    style ~property_rules
      [ scroll_snap_type (Axis_with_strictness (X, Var ref_)) ]

  let snap_y_s =
    let ref_ = Var.reference scroll_snap_strictness_var in
    let property_rules = Var.property_rules scroll_snap_strictness_var in
    style ~property_rules
      [ scroll_snap_type (Axis_with_strictness (Y, Var ref_)) ]

  let snap_both_s =
    let ref_ = Var.reference scroll_snap_strictness_var in
    let property_rules = Var.property_rules scroll_snap_strictness_var in
    style ~property_rules
      [ scroll_snap_type (Axis_with_strictness (Both, Var ref_)) ]

  let snap_mandatory_s =
    let d = Var.set scroll_snap_strictness_var Mandatory in
    let property_rules = Var.property_rules scroll_snap_strictness_var in
    style ~property_rules (d :: [])

  let snap_proximity_s =
    let d = Var.set scroll_snap_strictness_var Proximity in
    let property_rules = Var.property_rules scroll_snap_strictness_var in
    style ~property_rules (d :: [])

  let snap_align_none_s = style [ scroll_snap_align None ]
  let snap_normal_s = style [ scroll_snap_stop Normal ]
  let snap_always_s = style [ scroll_snap_stop Always ]
  let resize_none_s = style [ Css.resize None ]
  let resize_s = style [ Css.resize Both ]
  let resize_x_s = style [ Css.resize Horizontal ]
  let resize_y_s = style [ Css.resize Vertical ]

  (* Additional utilities *)
  let pointer_events_none_s = style [ pointer_events None ]
  let pointer_events_auto_s = style [ pointer_events Auto ]
  let appearance_auto_s = style [ appearance Auto ]
  let appearance_none_s = style [ appearance None ]
  let will_change_auto_s = style [ will_change Css.Will_change_auto ]
  let will_change_scroll_s = style [ will_change Css.Scroll_position ]
  let will_change_contents_s = style [ will_change Css.Contents ]
  let will_change_transform_s = style [ will_change Css.Transform ]
  let group_s = style []
  let peer_s = style []
  let scheme_dark_s = style [ color_scheme Dark ]
  let scheme_light_s = style [ color_scheme Light ]
  let scheme_light_dark_s = style [ color_scheme Light_dark ]
  let scheme_normal_s = style [ color_scheme Normal ]
  let scheme_only_dark_s = style [ color_scheme Only_dark ]
  let scheme_only_light_s = style [ color_scheme Only_light ]

  let to_style _theme = function
    | Select_none -> select_none_s
    | Select_text -> select_text_s
    | Select_all -> select_all_s
    | Select_auto -> select_auto_s
    | Scroll_auto -> scroll_auto_s
    | Scroll_smooth -> scroll_smooth_s
    | Snap_start -> snap_start_s
    | Snap_end -> snap_end_s
    | Snap_center -> snap_center_s
    | Snap_none -> snap_none_s
    | Snap_x -> snap_x_s
    | Snap_y -> snap_y_s
    | Snap_both -> snap_both_s
    | Snap_mandatory -> snap_mandatory_s
    | Snap_proximity -> snap_proximity_s
    | Snap_align_none -> snap_align_none_s
    | Snap_normal -> snap_normal_s
    | Snap_always -> snap_always_s
    | Resize_none -> resize_none_s
    | Resize -> resize_s
    | Resize_x -> resize_x_s
    | Resize_y -> resize_y_s
    | Pointer_events_none -> pointer_events_none_s
    | Pointer_events_auto -> pointer_events_auto_s
    | Appearance_auto -> appearance_auto_s
    | Appearance_none -> appearance_none_s
    | Will_change_auto -> will_change_auto_s
    | Will_change_scroll -> will_change_scroll_s
    | Will_change_contents -> will_change_contents_s
    | Will_change_transform -> will_change_transform_s
    | Will_change_arbitrary s ->
        if Parse.is_var s then
          let bare_name = Parse.extract_var_name s in
          style [ will_change (Var (Var.bracket bare_name)) ]
        else
          let raw = Parse.decode_underscores s in
          let props = String.split_on_char ',' raw |> List.map String.trim in
          style [ will_change (Properties props) ]
    | Group -> group_s
    | Peer -> peer_s
    | Scheme_dark -> scheme_dark_s
    | Scheme_light -> scheme_light_s
    | Scheme_light_dark -> scheme_light_dark_s
    | Scheme_normal -> scheme_normal_s
    | Scheme_only_dark -> scheme_only_dark_s
    | Scheme_only_light -> scheme_only_light_s

  let suborder = function
    | Scroll_auto -> 700
    | Scroll_smooth -> 701
    | Select_all -> 2
    | Select_auto -> 3
    | Select_none -> 4
    | Select_text -> 5
    (* Snap utilities are grouped by their property-order key. Candidate names
       settle ties inside each property band. *)
    | Snap_both | Snap_none | Snap_x | Snap_y -> 1_100_000
    | Snap_mandatory | Snap_proximity -> 1_110_000
    | Snap_align_none | Snap_center | Snap_end | Snap_start -> 1_120_000
    | Snap_always | Snap_normal -> 1_130_000
    (* resize (priority 11) - after cursor (<1000), before list-style (~2M) *)
    | Resize -> 1_000_000 + 22
    | Resize_none -> 1_000_000 + 23
    | Resize_x -> 1_000_000 + 24
    | Resize_y -> 1_000_000 + 25
    | Pointer_events_auto -> 26
    | Pointer_events_none -> 27
    (* appearance (priority 11) - after list-style (~2M) *)
    | Appearance_auto -> 3_000_000 + 28
    | Appearance_none -> 3_000_000 + 29
    | Will_change_auto -> 31
    | Will_change_contents -> 32
    | Will_change_scroll -> 33
    | Will_change_transform -> 34
    | Will_change_arbitrary _ -> 30
    | Group -> 35
    | Peer -> 36
    | Scheme_dark -> -100
    | Scheme_light -> -99
    | Scheme_light_dark -> -98
    | Scheme_normal -> -97
    | Scheme_only_dark -> -96
    | Scheme_only_light -> -95

  let of_class _theme class_name =
    let parts = Parse.split_class class_name in
    match parts with
    | [ "select"; "none" ] -> Ok Select_none
    | [ "select"; "text" ] -> Ok Select_text
    | [ "select"; "all" ] -> Ok Select_all
    | [ "select"; "auto" ] -> Ok Select_auto
    | [ "scroll"; "auto" ] -> Ok Scroll_auto
    | [ "scroll"; "smooth" ] -> Ok Scroll_smooth
    | [ "snap"; "start" ] -> Ok Snap_start
    | [ "snap"; "end" ] -> Ok Snap_end
    | [ "snap"; "center" ] -> Ok Snap_center
    | [ "snap"; "none" ] -> Ok Snap_none
    | [ "snap"; "x" ] -> Ok Snap_x
    | [ "snap"; "y" ] -> Ok Snap_y
    | [ "snap"; "both" ] -> Ok Snap_both
    | [ "snap"; "mandatory" ] -> Ok Snap_mandatory
    | [ "snap"; "proximity" ] -> Ok Snap_proximity
    | [ "snap"; "align"; "none" ] -> Ok Snap_align_none
    | [ "snap"; "normal" ] -> Ok Snap_normal
    | [ "snap"; "always" ] -> Ok Snap_always
    | [ "resize"; "none" ] -> Ok Resize_none
    | [ "resize" ] -> Ok Resize
    | [ "resize"; "x" ] -> Ok Resize_x
    | [ "resize"; "y" ] -> Ok Resize_y
    | [ "pointer"; "events"; "none" ] -> Ok Pointer_events_none
    | [ "pointer"; "events"; "auto" ] -> Ok Pointer_events_auto
    | [ "appearance"; "auto" ] -> Ok Appearance_auto
    | [ "appearance"; "none" ] -> Ok Appearance_none
    | [ "will"; "change"; "auto" ] -> Ok Will_change_auto
    | [ "will"; "change"; "scroll" ] -> Ok Will_change_scroll
    | [ "will"; "change"; "contents" ] -> Ok Will_change_contents
    | [ "will"; "change"; "transform" ] -> Ok Will_change_transform
    | [ "will"; "change"; value ] when Parse.is_bracket_value value ->
        let inner = Parse.bracket_inner value in
        (* [will-change] takes property names, so anything that is not an
           identifier - the docs' [<value>] placeholder included - is not
           one. *)
        if
          Parse.is_var inner
          || String.split_on_char ',' inner
             |> List.map String.trim
             |> List.for_all (fun p ->
                 Parse.is_ident (Parse.decode_underscores p |> String.trim))
        then Ok (Will_change_arbitrary inner)
        else err_not_utility
    | [ "group" ] -> Ok Group
    | [ "peer" ] -> Ok Peer
    | [ "scheme"; "dark" ] -> Ok Scheme_dark
    | [ "scheme"; "light" ] -> Ok Scheme_light
    | [ "scheme"; "light"; "dark" ] -> Ok Scheme_light_dark
    | [ "scheme"; "normal" ] -> Ok Scheme_normal
    | [ "scheme"; "only"; "dark" ] -> Ok Scheme_only_dark
    | [ "scheme"; "only"; "light" ] -> Ok Scheme_only_light
    | _ -> err_not_utility

  let to_class = function
    | Select_none -> "select-none"
    | Select_text -> "select-text"
    | Select_all -> "select-all"
    | Select_auto -> "select-auto"
    | Scroll_auto -> "scroll-auto"
    | Scroll_smooth -> "scroll-smooth"
    | Snap_start -> "snap-start"
    | Snap_end -> "snap-end"
    | Snap_center -> "snap-center"
    | Snap_none -> "snap-none"
    | Snap_x -> "snap-x"
    | Snap_y -> "snap-y"
    | Snap_both -> "snap-both"
    | Snap_mandatory -> "snap-mandatory"
    | Snap_proximity -> "snap-proximity"
    | Snap_align_none -> "snap-align-none"
    | Snap_normal -> "snap-normal"
    | Snap_always -> "snap-always"
    | Resize_none -> "resize-none"
    | Resize -> "resize"
    | Resize_x -> "resize-x"
    | Resize_y -> "resize-y"
    | Pointer_events_none -> "pointer-events-none"
    | Pointer_events_auto -> "pointer-events-auto"
    | Appearance_auto -> "appearance-auto"
    | Appearance_none -> "appearance-none"
    | Will_change_auto -> "will-change-auto"
    | Will_change_scroll -> "will-change-scroll"
    | Will_change_contents -> "will-change-contents"
    | Will_change_transform -> "will-change-transform"
    | Will_change_arbitrary s -> "will-change-[" ^ s ^ "]"
    | Group -> "group"
    | Peer -> "peer"
    | Scheme_dark -> "scheme-dark"
    | Scheme_light -> "scheme-light"
    | Scheme_light_dark -> "scheme-light-dark"
    | Scheme_normal -> "scheme-normal"
    | Scheme_only_dark -> "scheme-only-dark"
    | Scheme_only_light -> "scheme-only-light"

  let examples =
    [
      Select_none;
      Scroll_auto;
      Snap_x;
      Snap_start;
      Snap_always;
      Snap_mandatory;
      Resize_none;
      Pointer_events_none;
      Appearance_none;
      Will_change_auto;
      Scheme_dark;
    ]
end

open Handler
module Utility_factory = Utility.Make (Handler)

let utility = Utility_factory.v
let select_none = utility Select_none
let select_text = utility Select_text
let select_all = utility Select_all
let select_auto = utility Select_auto
let scroll_auto = utility Scroll_auto
let scroll_smooth = utility Scroll_smooth
let snap_start = utility Snap_start
let snap_end = utility Snap_end
let snap_center = utility Snap_center
let snap_none = utility Snap_none
let snap_x = utility Snap_x
let snap_y = utility Snap_y
let snap_both = utility Snap_both
let snap_mandatory = utility Snap_mandatory
let snap_proximity = utility Snap_proximity
let snap_align_none = utility Snap_align_none
let snap_normal = utility Snap_normal
let snap_always = utility Snap_always
let resize_none = utility Resize_none
let resize = utility Resize
let resize_x = utility Resize_x
let resize_y = utility Resize_y
let pointer_events_none = utility Pointer_events_none
let pointer_events_auto = utility Pointer_events_auto
let appearance_auto = utility Appearance_auto
let appearance_none = utility Appearance_none
let will_change_auto = utility Will_change_auto
let will_change_scroll = utility Will_change_scroll
let will_change_contents = utility Will_change_contents
let will_change_transform = utility Will_change_transform
let group = utility Group
let peer = utility Peer
let scheme_dark = utility Scheme_dark
let scheme_light = utility Scheme_light
let scheme_light_dark = utility Scheme_light_dark
let scheme_normal = utility Scheme_normal
let scheme_only_dark = utility Scheme_only_dark
let scheme_only_light = utility Scheme_only_light