Source file tw.ml

(** A type-safe, ergonomic DSL for Tailwind CSS using nominal types.

    This library takes inspiration from Tailwind CSS v3's utility-first approach
    while leveraging OCaml's type system for compile-time safety. We cherry-pick
    concepts that work well with OCaml and add our own innovations where
    appropriate.

    Key design decisions:
    - Pure OCaml implementation without external CSS dependencies
    - Type-safe API that prevents invalid CSS at compile time
    - Simplified spacing functions that accept integers directly
    - Support for modern CSS features like container queries and 3D transforms
    - Minimal bundle size for js_of_ocaml by avoiding Format module. *)

type t = Utility.t

include Color
include Backgrounds
include Margin
include Gap
include Padding
include Sizing
include Typography
include Layout
include Overflow
include Overscroll
include Overflow_wrap
include Box_sizing
include Tab
include Scrollbar
include Zoom
include Field_sizing
include Grid
include Grid_item
include Grid_template
include Flex
include Flex_props
include Flex_layout
include Alignment
include Borders
include Effects
include Text_shadow
include Transforms
include Cursor
include Touch
include Divide
include Interactivity
include Containers
include Filters
include Masks
include Mask_gradient
include Clipping
include Position
include Animations
include Transitions
include Forms
include Tables
include Svg
include Accessibility
include Modifiers
include Prose
include Columns
include Contain
include Scroll
include Arbitrary

let theme_token_rename = Build.theme_token_rename
let property_fallbacks = Build.author_property_fallbacks

let to_css ?theme ?(base = Build.default_config.base) ?forms
    ?(layers = Build.default_config.layers) ?extra utilities =
  Build.to_css ?theme ~config:{ base; forms; layers } ?extra utilities

let to_inline_style ?theme utilities = Build.to_inline_style ?theme utilities
let preflight = Preflight.stylesheet

(* Class generation functions *)
let pp utility = Utility.to_class utility
let to_classes styles = styles |> List.map Utility.to_class |> String.concat " "
let modifiers_of_string = Modifiers.of_string

let is_whitespace = function
  | ' ' | '\t' | '\n' | '\r' | '\012' -> true
  | _ -> false

let split_whitespace s =
  let current = Buffer.create 16 in
  let tokens = ref [] in
  let flush () =
    if Buffer.length current > 0 then (
      tokens := Buffer.contents current :: !tokens;
      Buffer.clear current)
  in
  String.iter
    (fun c -> if is_whitespace c then flush () else Buffer.add_char current c)
    s;
  flush ();
  List.rev !tokens

(* The v4 [prop-(--x)] shorthand is [prop-[var(--x)]] in value but keeps its own
   class name. Rewrite the trailing [(...)] to its bracket form for parsing; the
   original spelling is restored via [Utility.alias]. Handles the bare var
   [(--x)] / [(--x,fallback)] -> [[var(--x...)]] and the typed
   [(family-name:--x)] -> [[family-name:var(--x)]] forms. Returns [None] when
   there is no paren shorthand. *)
let rewrite_paren_var base_class =
  let n = String.length base_class in
  if n > 4 && base_class.[n - 1] = ')' then
    match String.rindex_opt base_class '(' with
    | Some lp when lp > 0 && base_class.[lp - 1] = '-' -> (
        let prefix = String.sub base_class 0 lp in
        let inner = String.sub base_class (lp + 1) (n - lp - 2) in
        let ilen = String.length inner in
        if ilen > 1 && inner.[0] = '-' && inner.[1] = '-' then
          (* bare var (with optional ,fallback) *)
          Some (prefix ^ "[var(" ^ inner ^ ")]")
        else
          (* typed hint: <type>:--name[,fallback] *)
          match String.index_opt inner ':' with
          | Some ci
            when ci + 2 < ilen && inner.[ci + 1] = '-' && inner.[ci + 2] = '-'
            ->
              let typ = String.sub inner 0 ci in
              let v = String.sub inner (ci + 1) (ilen - ci - 1) in
              Some (prefix ^ "[" ^ typ ^ ":var(" ^ v ^ ")]")
          | _ -> None)
    | _ -> None
  else None

(* The [/modifier] a class ends with, outside any brackets or parentheses, apart
   from what it modifies. *)
let split_trailing_modifier s =
  let n = String.length s in
  let rec last_slash i depth found =
    if i >= n then found
    else
      match s.[i] with
      | '(' | '[' -> last_slash (i + 1) (depth + 1) found
      | ')' | ']' -> last_slash (i + 1) (depth - 1) found
      | '/' when depth = 0 -> last_slash (i + 1) depth (Some i)
      | _ -> last_slash (i + 1) depth found
  in
  match last_slash 0 0 None with
  | Some i when i > 0 -> (String.sub s 0 i, String.sub s i (n - i))
  | _ -> (s, "")

(* A colour utility takes its opacity after the shorthand, [bg-(--c)/50], so the
   modifier is carried across the rewrite: the class then ends at its [/50]
   rather than at the [)] the rewrite looks for. *)
let normalize_paren_var base_class =
  let base, modifier = split_trailing_modifier base_class in
  Option.map (fun rewritten -> rewritten ^ modifier) (rewrite_paren_var base)

(* Split the [!] important marker off the base class: the v3 prefix ([!flex],
   [md:!flex]) or the v4 trailing form ([flex!]). Each keeps its form in the
   generated selector so it matches the source class. *)
let split_importance base_class =
  let n = String.length base_class in
  if n > 1 && base_class.[0] = '!' then
    (`Prefix, String.sub base_class 1 (n - 1))
  else if n > 1 && base_class.[n - 1] = '!' then
    (`Suffix, String.sub base_class 0 (n - 1))
  else (`None, base_class)

(* The alpha a [theme()] path carries, as the percentage to mix at: a percentage
   as written, a bare number as the fraction Tailwind reads it for. *)
let theme_alpha_percent a =
  let n = String.length a in
  if n > 1 && a.[n - 1] = '%' then float_of_string_opt (String.sub a 0 (n - 1))
  else Option.map (fun f -> f *. 100.) (float_of_string_opt a)

(* Tailwind applies a [theme()] alpha by mixing the colour with transparent,
   which reads whatever the [@theme] bound the palette entry to. *)
let theme_color_with_alpha base a =
  match (Cascade.Css.parse_color base, theme_alpha_percent a) with
  | Some color, Some percent1 ->
      Some
        (Cascade.Css.Pp.to_string Cascade.Css.pp_color
           (Cascade.Css.color_mix ~in_space:Oklab ~percent1 color
              Cascade.Css.Transparent))
  | _ -> None

(* The value the theme binds a [theme()] dot path to, before any alpha:
   [colors.<name>.<shade>] is the palette entry, [spacing.<n>] the spacing
   product. [None] is a path this does not resolve, which is not the same
   question as whether the theme carries the key. *)
let theme_key_value ~theme path =
  match String.split_on_char '.' path with
  | [ "colors"; name; shade ] -> (
      (* A project that renames or adds a palette entry in its [@theme] gets its
         own value back here, the way [bg-<name>-<shade>] already does. *)
      let token = String.concat "-" [ "color"; name; shade ] in
      match Scheme.theme_value (Some theme) token with
      | Some _ as v -> v
      | None -> (
          match (Color.of_string name, int_of_string_opt shade) with
          | Ok c, Some sh when Color.is_valid_shade c sh ->
              Some (Color.to_oklch_css c sh)
          | _ -> None))
  | [ "spacing"; n ] ->
      (* The step here is Tailwind's own 0.25rem and not whatever [--spacing]
         the project set: checked against the CLI with [@theme { --spacing:
         0.5rem }], both sheets still resolve [theme(spacing.4)] to [1rem], so
         reading the theme would lose parity rather than gain it.
         [Theme.spacing_times] is that same fixed product, and going through it
         is what keeps the two spellings of it in step. *)
      Option.bind (float_of_string_opt n) Theme.spacing_times
  | _ -> None

(* The value the resolved theme binds [--<name>] to, with the [\@layer theme]
   declaration that keeps the binding in the sheet. A registered default or a
   project override answers for itself; the palette answers through the same
   catalogue an arbitrary [var(--color-red-500)] reads, so a shaded entry and a
   shadeless one both resolve. [None] is a token the resolved theme does not
   carry. *)
let theme_token_binding ~theme name =
  match Scheme.token theme name with
  | Some css ->
      Some (css, Cascade.Css.custom_property ~layer:"theme" ("--" ^ name) css)
  | None ->
      Option.map
        (fun decl -> (Cascade.Css.declaration_value decl, decl))
        (Color.Handler.theme_color_decl ~theme name)

(* The token a [theme(--x)] names, resolved. This is the v4 spelling of the
   lookup, and it reads the token table itself rather than one of the v3
   namespaces the dot paths name. *)
let theme_token_value ~theme path =
  Option.bind (Parse.bare_name path) (theme_token_binding ~theme)

(* Resolve one theme() argument.

   [`Value] is the key resolved, mixed with the [/<alpha>] it carries when it
   has one. [`Token] is the same for the [--<name>] spelling, and carries the
   binding that keeps the token in the theme layer: unlike a dot path, that
   spelling does not consume it. [`Missing] is a key the theme provably does not
   carry, which Tailwind answers with no rule at all: a bare segment names no
   namespace, the palette namespace is one tw resolves in full, and the
   [--<name>] spelling reads the token table itself, so an absence there is an
   absence. [`Verbatim] is everything else - an alpha naming no number, and a
   namespace tw does not resolve - where there is no table saying the key is
   absent and Tailwind emits a rule for the ones it knows. *)
let theme_resolve_key ~theme key =
  let path, alpha =
    match String.index_opt key '/' with
    | Some k ->
        ( String.sub key 0 k,
          Some (String.sub key (k + 1) (String.length key - k - 1)) )
    | None -> (key, None)
  in
  let with_alpha base =
    match alpha with
    | None -> Some base
    | Some a -> theme_color_with_alpha base a
  in
  match theme_key_value ~theme path with
  | Some base -> (
      match with_alpha base with Some v -> `Value v | None -> `Verbatim)
  | None -> (
      match theme_token_value ~theme path with
      | Some (base, decl) -> (
          match with_alpha base with
          | Some v -> `Token (decl, v)
          | None -> `Verbatim)
      | None -> (
          match String.split_on_char '.' path with
          | "colors" :: _ | [ _ ] -> `Missing
          | _ -> `Verbatim))

(* Split a theme() argument into its key and the fallback after the first
   top-level comma, which stands in whenever the key resolves to nothing. *)
let theme_call_fallback inner =
  let n = String.length inner in
  let rec go i depth =
    if i >= n then (inner, None)
    else
      match inner.[i] with
      | '(' -> go (i + 1) (depth + 1)
      | ')' -> go (i + 1) (depth - 1)
      | ',' when depth = 0 ->
          (String.sub inner 0 i, Some (String.sub inner (i + 1) (n - i - 1)))
      | _ -> go (i + 1) depth
  in
  go 0 0

(* Replace each theme() call in a class string with what it resolves to, and
   report the theme tokens the calls read.

   [theme(<key>)] writes the resolved value back in the spelling an arbitrary
   value is read in: a space becomes [_] and an underscore [\_], so a project
   that binds a token to [var(--brand_red)] keeps the variable it named.
   [--theme(--<name>)] is the same lookup written as a reference, and writes
   [var(--<name>)] instead of the value; it admits neither a v3 dot path nor an
   alpha, both of which Tailwind reads some other way, so those are left for the
   class to fail on.

   [None] is a call naming a key the theme does not carry and offering no
   fallback: Tailwind emits no rule for such a class, so it is not a utility. *)
let resolve_theme_functions ~theme s =
  let buf = Buffer.create (String.length s) in
  let n = String.length s in
  let missing = ref false in
  let bindings = ref [] in
  let i = ref 0 in
  let resolved v = Buffer.add_string buf (Parse.encode_underscores v) in
  let opens j lit =
    j + String.length lit <= n && String.sub s j (String.length lit) = lit
  in
  while !i < n do
    let reference = opens !i "--theme(" in
    if reference || opens !i "theme(" then begin
      let open_len = if reference then 8 else 6 in
      let j = ref (!i + open_len) and depth = ref 1 in
      while !j < n && !depth > 0 do
        if s.[!j] = '(' then incr depth else if s.[!j] = ')' then decr depth;
        if !depth > 0 then incr j
      done;
      (* [!j] is the closing paren, or [n] when the call never closed - a
         truncated attribute or template artefact in scanned markup. An
         unterminated call has no key to read, so the rest of the string is
         copied through and the class stays unresolved. *)
      let closed = !depth = 0 in
      let inner = String.sub s (!i + open_len) (!j - (!i + open_len)) in
      let verbatim () =
        let stop = if closed then !j + 1 else n in
        Buffer.add_string buf (String.sub s !i (stop - !i))
      in
      (if not closed then verbatim ()
       else
         let key, fallback = theme_call_fallback inner in
         if reference && String.contains key '/' then verbatim ()
         else
           match theme_resolve_key ~theme key with
           | `Value v -> if reference then verbatim () else resolved v
           | `Token (decl, v) ->
               bindings := decl :: !bindings;
               (* [key] is the [--<name>] the call spelled: the reference form
                  bailed above on anything carrying an alpha, so the whole key
                  is the property name. *)
               if reference then Buffer.add_string buf ("var(" ^ key ^ ")")
               else resolved v
           | `Verbatim -> verbatim ()
           | `Missing -> (
               match fallback with
               | Some f -> Buffer.add_string buf f
               | None -> missing := true));
      i := if closed then !j + 1 else n
    end
    else begin
      Buffer.add_char buf s.[!i];
      incr i
    end
  done;
  if !missing then None else Some (Buffer.contents buf, List.rev !bindings)

(* Tailwind v4 removed the v3 opacity utilities: the opacity is written on the
   colour as a [/modifier]. The verdict does not change - the pinned CLI emits
   nothing for these either - but "unknown" reads as a typo, and a v3 class is
   not one. Only these six families are worth naming: every other v3 spelling
   that v4 renamed ([flex-grow], [overflow-ellipsis], [decoration-slice]) is
   still emitted by 4.3.3, so tw compiles it and must keep doing so. *)
let v3_opacity_replacement base_class =
  match String.split_on_char '-' base_class with
  | [ family; "opacity"; amount ]
    when amount <> ""
         && List.mem family
              [ "bg"; "text"; "border"; "divide"; "ring"; "placeholder" ] ->
      Some (String.concat "" [ family; "-<color>/"; amount ])
  | _ -> None

(* The rejection a class gets once no handler has claimed it. A bracket class
   that looks like an arbitrary property but that nothing accepted is malformed
   rather than unsupported: the bracket has no property name or does not end the
   class, or the modifier after it is not an opacity on a colour. *)
let unknown_class_error ~base_class class_str =
  if
    String.length base_class > 2
    && base_class.[0] = '['
    && String.contains base_class ':'
  then
    Error
      (`Msg
         ("Invalid arbitrary property '" ^ class_str
        ^ "': expected [property:value], optionally followed by an /opacity \
           modifier on a colour value (e.g. [color:var(--x)]/50)"))
  else
    match v3_opacity_replacement base_class with
    | Some replacement ->
        Error
          (`Msg
             ("Tailwind v4 removed '" ^ class_str
            ^ "': write the opacity on the colour, as " ^ replacement))
    | None -> Error (`Msg ("Unknown class: " ^ class_str))

(* Whether the candidate spells [name] itself. A [var(--x)] the author wrote
   into an arbitrary value is their reference, and Tailwind writes it through
   whatever the theme holds. *)
let spells class_str name =
  let n = String.length name and len = String.length class_str in
  let rec at i j = j = n || (class_str.[i + j] = name.[j] && at i (j + 1)) in
  let rec from i = i + n <= len && (at i 0 || from (i + 1)) in
  from 0

(* Tailwind compiles nothing for a candidate whose value the [@theme] block took
   away: [--text-*: initial] leaves [text-lg] no size to write. The palette and
   the breakpoints refuse such a candidate as they read it; every other family
   is held here, against the tokens its rules read. *)
let removed_token_read ~theme class_str u =
  if Scheme.removes_tokens theme then
    Build.removed_token_read ~theme ~authored:(spells class_str)
      (Rule.outputs ~theme u)
  else None

(* Parse a single class string into a Tw.t *)
let of_candidate ~theme class_str =
  let modifiers, base_class = modifiers_of_string class_str in
  let importance, base_class = split_importance base_class in
  (* Wrap [important] around the base before applying modifiers, so a
     responsive/state prefix stays outermost: md:!flex -> md:(!flex). An
     optional [alias] sits inside importance so [w-(--w)!] keeps both forms. *)
  let finish ?alias ?(bindings = []) base_utility =
    let base_util = Utility.base base_utility in
    let base_util =
      match alias with
      | Some cls -> Utility.alias cls base_util
      | None -> base_util
    in
    let base_util =
      match importance with
      | `Prefix -> Utility.important base_util
      | `Suffix -> Utility.important ~suffix:true base_util
      | `None -> base_util
    in
    (* Outside [important]: the binding is a theme declaration the utility drags
       in, not one of the declarations the [!] marks. *)
    let base_util = Utility.theme_bound bindings base_util in
    match Modifiers.apply ~theme modifiers base_util with
    | None -> Error (`Msg ("Unknown modifier in: " ^ class_str))
    | Some u -> (
        match removed_token_read ~theme class_str u with
        | None -> Ok u
        | Some token ->
            Error
              (`Msg
                 (Pp.str
                    [
                      class_str; " reads --"; token; ", which the theme removed";
                    ])))
  in
  (* Resolve theme() calls for dispatch, keeping the original spelling as the
     class-name alias so the utility still round-trips. A call naming no key
     leaves nothing to dispatch on. *)
  match resolve_theme_functions ~theme base_class with
  | None -> unknown_class_error ~base_class class_str
  | Some (resolved_base, bindings) -> (
      let theme_alias =
        if resolved_base = base_class then None else Some base_class
      in
      match Utility.base_of_class theme resolved_base with
      | Ok base_utility -> finish ?alias:theme_alias ~bindings base_utility
      | Error _ -> (
          (* Fallback: the v4 [prop-(--x)] shorthand for handlers that accept
             the [prop-[var(--x)]] form but not the paren spelling directly.
             Handlers that support [(--x)] natively (e.g. rotate) already
             matched above, so this never overrides them. The original spelling
             is kept via the alias. *)
          match normalize_paren_var base_class with
          | Some normalized -> (
              match Utility.base_of_class theme normalized with
              | Ok base_utility -> finish ~alias:base_class base_utility
              | Error _ -> Error (`Msg ("Unknown class: " ^ class_str)))
          | None -> unknown_class_error ~base_class class_str))

(* [prefix(tw)] puts [tw:] in front of every candidate. It is not a variant -
   nothing reads it as one - so it comes off here, before anything parses, and
   goes back on in [Rule.outputs], once the modifiers have composed the name
   underneath it. A candidate that does not carry the prefix names no utility,
   the way an unknown class names none: Tailwind compiles nothing for a bare
   [p-4] once the import asks for a prefix. *)
let strip_prefix theme class_str =
  match theme.Scheme.prefix with
  | None -> Some class_str
  | Some prefix ->
      let head = prefix ^ ":" in
      let n = String.length head in
      if String.length class_str > n && String.sub class_str 0 n = head then
        Some (String.sub class_str n (String.length class_str - n))
      else None

let of_string ?(theme = Scheme.default) class_str =
  match strip_prefix theme class_str with
  | None -> Error (`Msg ("Unknown class: " ^ class_str))
  | Some candidate -> of_candidate ~theme candidate

(* A name the parser rejects may be a typo or a deliberate non-tw class - a
   framework hook, a JS selector - and nothing here can tell the two apart. So
   parsing a class string never fails: it hands back what it recognised and what
   it did not, and the caller judges. *)
let of_classes ?theme s =
  let styles, unknown =
    List.fold_left
      (fun (styles, unknown) cls ->
        match of_string ?theme cls with
        | Ok t -> (t :: styles, unknown)
        | Error _ -> (styles, cls :: unknown))
      ([], []) (split_whitespace s)
  in
  (List.rev styles, List.rev unknown)

let str s = fst (of_classes s)

(** {1 Module Exports} *)

module Style = Style
module Margin = Margin
module Padding = Padding
module Gap = Gap
module Spacing = Spacing
module Flex = Flex
module Flex_props = Flex_props
module Flex_layout = Flex_layout
module Alignment = Alignment
module Cursor = Cursor
module Borders = Borders
module Backgrounds = Backgrounds
module Sizing = Sizing
module Layout = Layout
module Overflow = Overflow
module Overscroll = Overscroll
module Overflow_wrap = Overflow_wrap
module Box_sizing = Box_sizing
module Tab = Tab
module Scrollbar = Scrollbar
module Zoom = Zoom
module Field_sizing = Field_sizing
module Grid = Grid
module Grid_item = Grid_item
module Grid_template = Grid_template
module Typography = Typography
module Divide = Divide
module Effects = Effects
module Text_shadow = Text_shadow
module Transforms = Transforms
module Interactivity = Interactivity
module Containers = Containers
module Filters = Filters
module Masks = Masks
module Position = Position
module Animations = Animations
module Transitions = Transitions
module Forms = Forms
module Tables = Tables
module Svg = Svg
module Accessibility = Accessibility
module Output = Output
module Rule = Rule
module Build = Build
module Prose = Prose
module Css = Cascade.Css
module Color = Color
module Modifiers = Modifiers
module Var = Var
module Theme = Theme
module Scheme = Scheme
module Utility = Utility
module Columns = Columns
module Contain = Contain
module Scroll = Scroll
module Arbitrary = Arbitrary
module Touch = Touch
module Parse = Parse
module Mask_gradient = Mask_gradient
module Property = Property

(* Include flex utilities *)
include Flex

(* Include grid utilities *)
include Grid

(* Include cursor utilities *)
include Cursor