├── .gitignore ├── .ocamlformat ├── README.md ├── bin ├── dune └── main.ml ├── csso.opam ├── demo ├── dune ├── main.css └── main.mlx ├── dune-project └── lib ├── csso.ml ├── csso.mli ├── csso_lang.ml ├── csso_ppx.ml ├── csso_ppx.mli ├── csso_test.ml └── dune /.gitignore: -------------------------------------------------------------------------------- 1 | _opam 2 | _build 3 | node_modules 4 | package.json 5 | pnpm-lock.yaml 6 | .parrot.md 7 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/andreypopp/csso/7c5c41d45b90c5802dbb23dda1384ede74f37300/.ocamlformat -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # csso 2 | 3 | Atomic CSS for OCaml (and ReasonML). 4 | 5 | ## Usage 6 | 7 | Specify CSS styles using OCaml syntax, either as let-bindings on the top level: 8 | ```ocaml 9 | let%csso box = 10 | flex_basis `auto; 11 | width (`px 100) 12 | ``` 13 | 14 | or as expression in the `[%csso ...]` extension: 15 | ```ocaml 16 | let square n = [%csso height (`px n); width (`px n)] 17 | ``` 18 | 19 | or directly in the `csso` attribute: 20 | ```ocaml 21 | module Page = struct 22 | let make () = 23 |
24 | (React.string "hello!") 25 |
26 | [@@react.component] 27 | end 28 | ``` 29 | 30 | Configure `csso.ppx` preprocessor in `dune` file: 31 | ```lisp 32 | (melange.emit 33 | (preprocess 34 | (pps csso.ppx reason-react-ppx)) 35 | (libraries reason-react) 36 | (target commonjs)) 37 | ``` 38 | 39 | Setup a dune rule to generate extracted CSS: 40 | ```lisp 41 | (rule 42 | (target main.css) 43 | (mode promote) 44 | (deps 45 | (glob_files *.pp.ml)) 46 | (action 47 | (with-stdout-to 48 | %{target} 49 | (run csso %{deps})))) 50 | ``` 51 | 52 | The extracted CSS will look like: 53 | ```css 54 | .flex-basis-auto { flex-basis: auto; } 55 | .height-dynamic { height: var(--height); } 56 | .width-100px { width: 100px; } 57 | .width-dynamic { width: var(--width); } 58 | ``` 59 | 60 | and the generated HTML for the React component: 61 | ```html 62 |
64 | hello! 65 |
66 | ``` 67 | 68 | ## Syntax 69 | 70 | Within the `[%csso ...]` extension, the following syntax is supported: 71 | - `property arg...` where `property` is a CSS property and `args...` is a set of arguments 72 | - `use expr` where `expr` is an arbitrary OCaml expression of type `Csso.style` 73 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (public_name csso) 3 | (name main) 4 | (libraries ppxlib csso_ppx)) 5 | -------------------------------------------------------------------------------- /bin/main.ml: -------------------------------------------------------------------------------- 1 | let extract_stylesheet s filename = 2 | if String.ends_with filename ~suffix:".css" then 3 | Csso_ppx.Stylesheet.of_css filename s 4 | else if String.ends_with filename ~suffix:".pp.ml" then 5 | Csso_ppx.Stylesheet.of_ml filename s 6 | else failwith "Expected .css or .pp.ml file" 7 | 8 | let () = 9 | let stylesheet = 10 | Array.to_seq Sys.argv |> Seq.drop (* prog name *) 1 11 | |> Seq.fold_left extract_stylesheet Csso_ppx.Stylesheet.empty 12 | in 13 | Csso_ppx.Stylesheet.output_css stdout stylesheet 14 | -------------------------------------------------------------------------------- /csso.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "A short synopsis" 4 | description: "A longer description" 5 | maintainer: ["Maintainer Name"] 6 | authors: ["Author Name"] 7 | license: "LICENSE" 8 | tags: ["topics" "to describe" "your" "project"] 9 | homepage: "https://github.com/username/reponame" 10 | doc: "https://url/to/documentation" 11 | bug-reports: "https://github.com/username/reponame/issues" 12 | depends: [ 13 | "ocaml" 14 | "dune" {>= "3.16"} 15 | "odoc" {with-doc} 16 | ] 17 | build: [ 18 | ["dune" "subst"] {dev} 19 | [ 20 | "dune" 21 | "build" 22 | "-p" 23 | name 24 | "-j" 25 | jobs 26 | "@install" 27 | "@runtest" {with-test} 28 | "@doc" {with-doc} 29 | ] 30 | ] 31 | dev-repo: "git+https://github.com/username/reponame.git" 32 | -------------------------------------------------------------------------------- /demo/dune: -------------------------------------------------------------------------------- 1 | (melange.emit 2 | (preprocess 3 | (pps csso.ppx reason-react-ppx melange.ppx)) 4 | (libraries reason-react) 5 | (target commonjs)) 6 | 7 | (rule 8 | (target main.css) 9 | (mode promote) 10 | (deps 11 | (glob_files *.pp.ml)) 12 | (action 13 | (with-stdout-to 14 | %{target} 15 | (run csso %{deps})))) 16 | -------------------------------------------------------------------------------- /demo/main.css: -------------------------------------------------------------------------------- 1 | .flex-basis-auto { flex-basis: auto; } 2 | .height-dyn { height: var(--height); } 3 | .width-100px { width: 100px; } 4 | .width-dyn { width: var(--width); } 5 | -------------------------------------------------------------------------------- /demo/main.mlx: -------------------------------------------------------------------------------- 1 | let%csso box = 2 | flex_basis `auto; 3 | width (`px 100) 4 | 5 | let square n = [%csso 6 | height (`px n); 7 | width (`px n)] 8 | 9 | module Page = struct 10 | let make () = 11 |
12 |

13 | (React.string "hello!") 14 |

15 | [@@react.component] 16 | end 17 | 18 | let () = 19 | print_endline 20 | @@ ReactDOMServer.renderToString 21 | @@ 22 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.16) 2 | (using melange 0.1) 3 | 4 | (name csso) 5 | 6 | (generate_opam_files true) 7 | 8 | (source 9 | (github username/reponame)) 10 | 11 | (authors "Author Name") 12 | 13 | (maintainers "Maintainer Name") 14 | 15 | (license LICENSE) 16 | 17 | (documentation https://url/to/documentation) 18 | 19 | (package 20 | (name csso) 21 | (synopsis "A short synopsis") 22 | (description "A longer description") 23 | (depends ocaml dune) 24 | (tags 25 | (topics "to describe" your project))) 26 | 27 | (dialect 28 | (name mlx) 29 | (implementation 30 | (extension mlx) 31 | (merlin_reader mlx) 32 | (preprocess 33 | (run mlx-pp %{input-file})))) 34 | -------------------------------------------------------------------------------- /lib/csso.ml: -------------------------------------------------------------------------------- 1 | [@@@ocaml.warning "-69"] 2 | 3 | type style = { classes : < > Js.t; style : < > Js.t; className : string option } 4 | 5 | let no_style = Js.Obj.empty () 6 | let no_classes = Js.Obj.empty () 7 | let empty = { classes = no_classes; style = no_style; className = None } 8 | 9 | external make : 10 | < classes : < .. > Js.t ; style : < .. > Js.t ; className : string option > 11 | Js.t -> 12 | style = "%identity" 13 | 14 | external style : style -> ReactDOM.style = "style" [@@mel.get] 15 | external className : style -> string option = "className" [@@mel.get] 16 | 17 | let merge xs = 18 | let len = Js.Array.length xs in 19 | if len = 0 then empty 20 | else if len = 1 then Js.Array.unsafe_get xs 0 21 | else 22 | let classes = Js.Obj.empty () in 23 | let style = Js.Obj.empty () in 24 | for i = 0 to len - 1 do 25 | let x = Js.Array.unsafe_get xs i in 26 | ignore (Js.Obj.assign classes x.classes); 27 | ignore (Js.Obj.assign style x.style) 28 | done; 29 | let className = 30 | let values = Js.Dict.values (Obj.magic classes) in 31 | Some (Js.Array.join ~sep:" " values) 32 | in 33 | { classes; style; className } 34 | -------------------------------------------------------------------------------- /lib/csso.mli: -------------------------------------------------------------------------------- 1 | type style 2 | 3 | val empty : style 4 | 5 | external make : 6 | < classes : < .. > Js.t ; style : < .. > Js.t ; className : string option > 7 | Js.t -> 8 | style = "%identity" 9 | 10 | external style : style -> ReactDOM.style = "style" [@@mel.get] 11 | external className : style -> string option = "className" [@@mel.get] 12 | val merge : style array -> style 13 | -------------------------------------------------------------------------------- /lib/csso_lang.ml: -------------------------------------------------------------------------------- 1 | type 'a cssgen = string array * ('a -> string array) 2 | 3 | let flex_basis : [ `auto | `px of int ] cssgen = 4 | let f = function 5 | | `auto -> [| "auto" |] 6 | | `px n -> [| string_of_int n ^ "px" |] 7 | in 8 | ([| "flex-basis" |], f) 9 | 10 | let width : [ `px of int ] cssgen = 11 | let f = function `px n -> [| string_of_int n ^ "px" |] in 12 | ([| "width" |], f) 13 | 14 | let height : [ `px of int ] cssgen = 15 | let f = function `px n -> [| string_of_int n ^ "px" |] in 16 | ([| "height" |], f) 17 | -------------------------------------------------------------------------------- /lib/csso_ppx.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | open Printf 3 | module String_map = Map.Make (String) 4 | 5 | module Spec : sig 6 | type t 7 | 8 | val css : label array -> string array -> t 9 | (** statically known stylesheet *) 10 | 11 | val dyn : label array -> expression -> t 12 | (** dynamically computed stylesheet *) 13 | 14 | val merge : t list -> t 15 | (** merge multiple stylesheets *) 16 | 17 | val to_class_name : t -> string list 18 | val to_css : t -> string list 19 | val to_expression : loc:Location.t -> t -> expression 20 | end = struct 21 | type t = value String_map.t 22 | 23 | and value = 24 | | Css of string (* a statically known css value *) 25 | | Dyn of expression * label * int 26 | (* a dynamic css value, as an expression which evaluates to an array and an 27 | index into the array *) 28 | 29 | let css keys vals : t = 30 | String_map.of_seq 31 | (Array.to_seq keys |> Seq.mapi (fun i k -> (k, Css vals.(i)))) 32 | 33 | let dyn keys expr : t = 34 | let name = gen_symbol ~prefix:"css" () in 35 | String_map.of_seq 36 | (Array.to_seq keys |> Seq.mapi (fun i k -> (k, Dyn (expr, name, i)))) 37 | 38 | let merge a b = 39 | String_map.merge 40 | (fun _ a b -> 41 | match (a, b) with 42 | | Some _, Some v | Some v, None | None, Some v -> Some v 43 | | None, None -> None) 44 | a b 45 | 46 | let merge xs = List.fold_left merge String_map.empty xs 47 | let css_to_class_name = sprintf "%s-%s" 48 | let dyn_to_class_name = sprintf "%s-dyn" 49 | 50 | let to_class_name v = 51 | String_map.to_seq v 52 | |> Seq.map (fun (n, v) -> 53 | match v with 54 | | Css v -> css_to_class_name n v 55 | | Dyn _ -> dyn_to_class_name n) 56 | |> List.of_seq 57 | 58 | let to_css v = 59 | String_map.to_seq v 60 | |> Seq.map (fun (n, v) -> 61 | match v with 62 | | Css v -> sprintf ".%s { %s: %s; }" (css_to_class_name n v) n v 63 | | Dyn _ -> sprintf ".%s { %s: var(--%s); }" (dyn_to_class_name n) n n) 64 | |> List.of_seq 65 | 66 | let to_expression ~loc v = 67 | let open Ast_builder.Default in 68 | if String_map.is_empty v then [%expr Csso.empty] 69 | else 70 | let used = ref String_map.empty in 71 | let classes, styles = 72 | let style_name n = { txt = Lident (sprintf "--%s" n); loc } in 73 | let class_info n class_name = 74 | let classes = ({ txt = Lident n; loc }, estring ~loc class_name) in 75 | (class_name, classes) 76 | in 77 | String_map.to_seq v 78 | |> Seq.map (fun (n, v) -> 79 | match v with 80 | | Css v -> 81 | let class_name = css_to_class_name n v in 82 | let styles = (style_name n, [%expr Js.Undefined.empty]) in 83 | (class_info n class_name, styles) 84 | | Dyn (e, en, idx) -> 85 | let class_name = dyn_to_class_name n in 86 | used := String_map.add en e !used; 87 | let styles = 88 | ( style_name n, 89 | [%expr 90 | Js.Undefined.return 91 | (Array.get [%e evar ~loc:e.pexp_loc en] 92 | [%e eint ~loc idx])] ) 93 | in 94 | (class_info n class_name, styles)) 95 | |> List.of_seq |> List.split 96 | in 97 | let class_names, classes = List.split classes in 98 | let classes = pexp_record ~loc classes None in 99 | let styles = pexp_record ~loc styles None in 100 | let className = estring ~loc (String.concat " " class_names) in 101 | let expr = 102 | [%expr 103 | Csso.make 104 | [%mel.obj 105 | { 106 | classes = [%mel.obj [%e classes]]; 107 | style = [%mel.obj [%e styles]]; 108 | className = Some [%e className]; 109 | }]] 110 | in 111 | String_map.fold 112 | (fun k v expr -> 113 | [%expr 114 | let [%p pvar ~loc k] = [%e v] in 115 | [%e expr]]) 116 | !used expr 117 | end 118 | 119 | module Arg_spec : sig 120 | [@@@ocaml.warning "-32"] 121 | 122 | type _ t 123 | 124 | val bool : bool t 125 | val int : int t 126 | val float : float t 127 | val string : string t 128 | 129 | type _ tuple 130 | 131 | val variant : (string * 'x tuple) list -> 'x t 132 | val case0 : string -> string * unit tuple 133 | val case1 : string -> 'x t -> string * 'x tuple 134 | val case2 : string -> 'x t -> 'y t -> string * ('x * 'y) tuple 135 | val ( --> ) : string * 'x tuple -> ('x -> 'y) -> string * 'y tuple 136 | 137 | type _ a 138 | 139 | val return : 'x -> 'x a 140 | val ( $ ) : ('x -> 'y) a -> 'x t -> 'y a 141 | 142 | type args = (arg_label * expression) list 143 | 144 | val eval : 'x a -> args -> 'x option 145 | end = struct 146 | type _ t = 147 | | I : int t 148 | | F : float t 149 | | S : string t 150 | | B : bool t 151 | | V : (string * 'x tuple) list -> 'x t 152 | 153 | and _ tuple = 154 | | T0 : unit tuple 155 | | T1 : 'x t -> 'x tuple 156 | | T2 : 'x t * 'y t -> ('x * 'y) tuple 157 | | TF : 'x tuple * ('x -> 'y) -> 'y tuple 158 | 159 | let int = I 160 | let float = F 161 | let string = S 162 | let bool = B 163 | let variant cases = V cases 164 | let case0 l = (l, T0) 165 | let case1 l t = (l, T1 t) 166 | let case2 l x y = (l, T2 (x, y)) 167 | let ( --> ) (l, x) y = (l, TF (x, y)) 168 | 169 | (** argument specification *) 170 | type _ a = R : 'a -> 'a a | A : ('a -> 'b) a * 'a t -> 'b a 171 | 172 | let return v = R v 173 | let ( $ ) f t = A (f, t) 174 | 175 | type args = (arg_label * expression) list 176 | 177 | let ( let* ) = Option.bind 178 | 179 | let rec parse_expression : type x. x t -> expression -> x option = 180 | fun t e -> 181 | match (t, e) with 182 | | I, { pexp_desc = Pexp_constant (Pconst_integer (v, _)); _ } -> 183 | Some (int_of_string v) 184 | | F, { pexp_desc = Pexp_constant (Pconst_float (v, _)); _ } -> 185 | Some (float_of_string v) 186 | | S, { pexp_desc = Pexp_constant (Pconst_string (v, _, _)); _ } -> Some v 187 | | B, { pexp_desc = Pexp_construct ({ txt = Lident "true"; _ }, None); _ } -> 188 | Some true 189 | | B, { pexp_desc = Pexp_construct ({ txt = Lident "false"; _ }, None); _ } 190 | -> 191 | Some true 192 | | V cases, { pexp_desc = Pexp_variant (l', payload); _ } -> ( 193 | let rec eval_tuple : type x. x tuple -> expression option -> x option = 194 | fun t e -> 195 | match (t, e) with 196 | | T0, None -> Some () 197 | | T1 t, Some x' -> 198 | let* x = parse_expression t x' in 199 | Some x 200 | | T2 (x, y), Some { pexp_desc = Pexp_tuple [ x'; y' ]; _ } -> 201 | let* x = parse_expression x x' in 202 | let* y = parse_expression y y' in 203 | Some (x, y) 204 | | TF (t, f), x -> 205 | let* x = eval_tuple t x in 206 | Some (f x) 207 | | _, _ -> None 208 | in 209 | match List.assoc_opt l' cases with 210 | | None -> None 211 | | Some t -> eval_tuple t payload) 212 | | _, _ -> None 213 | 214 | let parse_arg args label : args * expression option = 215 | let rec go seen args = 216 | match (args, label) with 217 | | [], _ -> (List.rev seen, None) 218 | | (Nolabel, e) :: args, None -> (List.rev_append seen args, Some e) 219 | | ((Labelled l' | Optional l'), e) :: args, Some l when String.equal l l' 220 | -> 221 | (List.rev_append seen args, Some e) 222 | | arg :: args, _ -> go (arg :: seen) args 223 | in 224 | go [] args 225 | 226 | let rec eval : type x. x a -> args -> x option = 227 | fun spec args -> 228 | match spec with 229 | | R x -> Some x 230 | | A (f, t) -> 231 | let args, e = parse_arg args None in 232 | let* e = e in 233 | let* x = parse_expression t e in 234 | let* f = eval f args in 235 | Some (f x) 236 | end 237 | 238 | module Specs : sig 239 | val of_expression : 240 | loc:location -> expression -> (Spec.t, expression) Either.t 241 | 242 | val all : unit -> Spec.t list 243 | end = struct 244 | let found_specs : Spec.t list ref = ref [] 245 | let all () = !found_specs 246 | 247 | let css_func (keys, f) = 248 | let f x = Spec.css keys (f x) in 249 | Arg_spec.return f 250 | 251 | let specs : (expression * string array * Spec.t Arg_spec.a) list = 252 | let px () = Arg_spec.(case1 "px" int --> fun x -> `px x) in 253 | let auto () = Arg_spec.(case0 "auto" --> fun () -> `auto) in 254 | let loc = Location.none in 255 | [ 256 | ( [%expr Csso_lang.flex_basis], 257 | fst Csso_lang.flex_basis, 258 | Arg_spec.(css_func Csso_lang.flex_basis $ variant [ auto (); px () ]) ); 259 | ( [%expr Csso_lang.width], 260 | fst Csso_lang.width, 261 | Arg_spec.(css_func Csso_lang.width $ variant [ px () ]) ); 262 | ( [%expr Csso_lang.height], 263 | fst Csso_lang.height, 264 | Arg_spec.(css_func Csso_lang.height $ variant [ px () ]) ); 265 | ] 266 | 267 | let specs = 268 | List.fold_left 269 | (fun acc (e, p, v) -> 270 | let k = 271 | match e with 272 | | { 273 | pexp_desc = Pexp_ident { txt = Ldot (Lident "Csso_lang", k); _ }; 274 | _; 275 | } -> 276 | k 277 | | _ -> assert false 278 | in 279 | String_map.add k (e, p, v) acc) 280 | String_map.empty specs 281 | 282 | let of_expression ~loc e = 283 | let open Ast_builder.Default in 284 | let spec = 285 | match e with 286 | | [%expr use [%e? v]] -> Either.Right v 287 | | e -> ( 288 | let v = 289 | let ( let* ) = Option.bind in 290 | let* k, args = 291 | match e with 292 | | { 293 | pexp_desc = 294 | Pexp_apply 295 | ({ pexp_desc = Pexp_ident { txt = Lident k; _ }; _ }, args); 296 | _; 297 | } -> 298 | Some (k, args) 299 | | _ -> None 300 | in 301 | let* f, props, spec = String_map.find_opt k specs in 302 | let e = pexp_apply ~loc [%expr snd [%e f]] args in 303 | match Arg_spec.eval spec args with 304 | | None -> Some (Spec.dyn props e) 305 | | Some spec -> Some spec 306 | in 307 | match v with 308 | | Some v -> Left v 309 | | None -> 310 | Location.raise_errorf ~loc:e.pexp_loc 311 | "invalid style declaration, did you forget to use `use`?") 312 | in 313 | let () = 314 | match spec with 315 | | Left spec -> found_specs := spec :: !found_specs 316 | | Right _ -> () 317 | in 318 | spec 319 | end 320 | 321 | let compile_props ~loc es = 322 | let open Ast_builder.Default in 323 | let rec go specs acc = function 324 | | [] -> List.rev (compile_specs specs acc) 325 | | e :: es -> ( 326 | match Specs.of_expression ~loc e with 327 | | Either.Left spec -> go (spec :: specs) acc es 328 | | Right e -> go [] (e :: compile_specs specs acc) es) 329 | and compile_specs specs acc = 330 | match specs with 331 | | [] -> acc 332 | (*| specs -> Spec.to_expression ~loc (Spec.merge specs) :: acc*) 333 | | specs -> Spec.to_expression ~loc (Spec.merge specs) :: acc 334 | in 335 | let es = go [] [] es in 336 | [%expr 337 | let open Csso_lang in 338 | let _ = height in 339 | [%e 340 | match es with 341 | | [] -> [%expr Csso.empty] 342 | | [ e ] -> e 343 | | _ -> [%expr Csso.merge [%e pexp_array ~loc es]]]] 344 | 345 | let extension_stri = 346 | let pattern = 347 | let open Ast_pattern in 348 | let extractor_in_let = 349 | pstr_value drop (value_binding ~pat:__ ~expr:(esequence __) ^:: nil) 350 | in 351 | pstr @@ extractor_in_let ^:: nil 352 | in 353 | let expand ~ctxt p es = 354 | let loc = Expansion_context.Extension.extension_point_loc ctxt in 355 | let e = compile_props ~loc es in 356 | [%stri let [%p p] = [%e e]] 357 | in 358 | Context_free.Rule.extension 359 | (Extension.V3.declare "csso" Extension.Context.structure_item pattern expand) 360 | 361 | let extension_expr = 362 | let pattern = 363 | let open Ast_pattern in 364 | single_expr_payload (esequence __) 365 | in 366 | let expand ~ctxt es = 367 | let loc = Expansion_context.Extension.extension_point_loc ctxt in 368 | compile_props ~loc es 369 | in 370 | Context_free.Rule.extension 371 | (Extension.V3.declare "csso" Extension.Context.expression pattern expand) 372 | 373 | let is_jsx expr = 374 | List.exists 375 | (function { attr_name = { txt = "JSX"; _ }; _ } -> true | _ -> false) 376 | expr.pexp_attributes 377 | 378 | let is_html_element = function 379 | | "div" | "span" | "a" | "button" | "input" | "label" | "img" | "ul" | "li" 380 | | "ol" | "h1" | "h2" | "h3" | "h4" | "h5" | "h6" | "p" | "form" | "textarea" 381 | | "select" | "option" | "table" | "tr" | "td" | "th" | "thead" | "tbody" 382 | | "tfoot" | "nav" | "header" | "footer" | "section" | "article" | "aside" 383 | | "main" | "figure" | "figcaption" | "blockquote" | "cite" | "pre" | "code" 384 | | "abbr" | "acronym" | "address" | "b" | "strong" | "i" | "em" | "mark" 385 | | "small" | "del" | "ins" | "sub" | "sup" | "s" | "u" | "var" | "kbd" | "samp" 386 | | "q" | "dfn" | "ruby" | "rt" | "rp" | "bdo" | "br" | "wbr" | "hr" | "meter" 387 | | "progress" | "time" | "audio" | "video" | "source" | "track" | "embed" 388 | | "object" | "param" | "canvas" | "map" | "area" | "svg" | "math" | "iframe" 389 | | "frame" | "frameset" | "noframes" | "details" | "summary" | "dialog" 390 | | "menu" | "menuitem" | "legend" | "fieldset" | "datalist" | "keygen" 391 | | "output" | "slot" | "template" | "caption" | "col" | "colgroup" -> 392 | true 393 | | _ -> false 394 | 395 | let jsx_rewrite = 396 | object 397 | inherit Ast_traverse.map as super 398 | 399 | method! expression : expression -> expression = 400 | fun expr -> 401 | let loc = expr.pexp_loc in 402 | let make s tag args = 403 | [%expr 404 | let s = [%e s] in 405 | let className = Csso.className s in 406 | let style = Csso.style s in 407 | [%e { expr with pexp_desc = Pexp_apply (tag, args) }]] 408 | in 409 | let extract_spec expr tag args = 410 | let exception Nope in 411 | try 412 | let loc = expr.pexp_loc in 413 | let () = 414 | match tag.pexp_desc with 415 | | Pexp_ident { txt = Lident name; _ } when is_html_element name -> 416 | () 417 | | _ -> raise Nope 418 | in 419 | let found = ref None in 420 | let args = 421 | List.concat_map 422 | (function 423 | | Labelled "csso", arg -> 424 | found := Some arg; 425 | [ 426 | (Optional "className", [%expr className]); 427 | (Labelled "style", [%expr style]); 428 | ] 429 | | arg_label, arg -> [ (arg_label, super#expression arg) ]) 430 | args 431 | in 432 | match !found with 433 | | None -> raise Nope 434 | | Some arg -> 435 | let pat = Ast_pattern.(elist __) in 436 | Some 437 | (match Ast_pattern.parse_res pat loc arg Fun.id with 438 | | Error _ -> `Expr (arg, args) 439 | | Ok es -> `Specs (es, args)) 440 | with Nope -> None 441 | in 442 | match expr.pexp_desc with 443 | | Pexp_apply (tag, args) when is_jsx expr -> ( 444 | match extract_spec expr tag args with 445 | | None -> expr 446 | | Some (`Expr (s, args)) -> make s tag args 447 | | Some (`Specs (s, args)) -> 448 | let s = compile_props ~loc s in 449 | make s tag args) 450 | | _ -> super#expression expr 451 | end 452 | 453 | let impl (str : structure) = 454 | let open Ast_builder.Default in 455 | let loc = Location.none in 456 | List.fold_left 457 | (fun str spec -> 458 | let name = Spec.to_class_name spec in 459 | let name = String.concat " " name in 460 | let css = Spec.to_css spec in 461 | let css = String.concat "\n" css in 462 | [%stri [@@@CSS [%e estring ~loc name], [%e estring ~loc css]]] :: str) 463 | str (Specs.all ()) 464 | 465 | let () = 466 | Driver.register_transformation "csso" 467 | ~rules:[ extension_stri; extension_expr ] 468 | ~preprocess_impl:jsx_rewrite#structure ~impl 469 | 470 | module Stylesheet = struct 471 | module String_map = Map.Make (String) 472 | 473 | type t = string String_map.t 474 | 475 | let empty = String_map.empty 476 | 477 | let of_structure s css = 478 | let get_string e = 479 | match e.pexp_desc with 480 | | Pexp_constant (Pconst_string (v, _, None)) -> v 481 | | _ -> assert false 482 | in 483 | List.fold_left 484 | (fun css item -> 485 | match item with 486 | | [%stri [@@@CSS [%e? k], [%e? v]]] -> 487 | let k = get_string k in 488 | let v = get_string v in 489 | String_map.add k v css 490 | | _ -> css) 491 | css s 492 | 493 | let of_ml filename css = 494 | match Ppxlib.Ast_io.read_binary filename with 495 | | Error _ -> css 496 | | Ok t -> ( 497 | match Ppxlib.Ast_io.get_ast t with 498 | | Impl s -> of_structure s css 499 | | Intf _ -> (* no CSS in interfaces *) css) 500 | 501 | let of_css filename css = 502 | In_channel.with_open_bin filename @@ fun ic -> 503 | let rec loop css = 504 | match In_channel.input_line ic with 505 | | None -> css 506 | | Some v -> ( 507 | match String.index v ' ' with 508 | | exception Not_found -> loop css 509 | | i -> 510 | let k = String.sub v 0 i in 511 | loop (String_map.add k v css)) 512 | in 513 | loop css 514 | 515 | let output_css oc = 516 | String_map.iter (fun _ v -> 517 | output_string oc v; 518 | output_char oc '\n') 519 | end 520 | -------------------------------------------------------------------------------- /lib/csso_ppx.mli: -------------------------------------------------------------------------------- 1 | module Stylesheet : sig 2 | type t 3 | (** Extracted CSS stylesheet. *) 4 | 5 | val empty : t 6 | (** An empty stylesheet. *) 7 | 8 | val of_ml : string -> t -> t 9 | (** Extract the CSS from an OCaml parsetree and add it to the stylesheet. *) 10 | 11 | val of_css : string -> t -> t 12 | (** Extract the CSS from a CSS file and add it to the stylesheet. *) 13 | 14 | val output_css : Out_channel.t -> t -> unit 15 | (** Output the stylesheet's CSS to a channel. *) 16 | end 17 | -------------------------------------------------------------------------------- /lib/csso_test.ml: -------------------------------------------------------------------------------- 1 | let () = Ppxlib.Driver.standalone () 2 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name csso_ppx) 3 | (public_name csso.ppx) 4 | (modules csso_ppx) 5 | (preprocess 6 | (pps ppxlib.metaquot)) 7 | (kind ppx_rewriter) 8 | (ppx_runtime_libraries csso) 9 | (libraries ppxlib csso_lang)) 10 | 11 | (library 12 | (name csso) 13 | (public_name csso) 14 | (modules csso) 15 | (modes melange) 16 | (preprocess 17 | (pps melange.ppx)) 18 | (libraries 19 | reason-react 20 | (re_export csso_lang))) 21 | 22 | (library 23 | (name csso_lang) 24 | (public_name csso.value) 25 | (modes :standard melange) 26 | (modules csso_lang)) 27 | 28 | (executable 29 | (name csso_test) 30 | (libraries csso.ppx) 31 | (modules csso_test)) 32 | --------------------------------------------------------------------------------