Permalink
Browse files

Works as before but with the new Css.t as output. Now need to make th…

…e nested declaration work.
  • Loading branch information...
1 parent 7830b07 commit 29bbae0d5bf765ccea71ae9e446372703ab90686 @samoht committed Nov 14, 2010
Showing with 85 additions and 55 deletions.
  1. +3 −2 Makefile
  2. +1 −0 _tags
  3. +5 −5 cass_ast.ml
  4. +4 −2 cass_location.ml
  5. +9 −16 cass_quotations.ml
  6. +54 −29 css.ml
  7. +9 −1 css.mli
View
@@ -29,9 +29,10 @@ test:
ocamlbuild -pp "camlp4o $(INCLS) cass.cma" test.byte --
.PHONY: text_exp
-test_exp: test.ml
+test_exp: test.ml $(BFILES)
camlp4of $(INCLS) _build/cass.cma test.ml -printer o > test_exp.ml
- ocamlc -annot -I _build/ css.cmo test_exp.ml -o test_exp
+ ocamlc -g -annot -I _build/ css.cmo test_exp.ml -o test_exp
+ ./test_exp
debug: all
camlp4of _build/cass.cma test.ml
View
1 _tags
@@ -1,3 +1,4 @@
+true: debug
<cass_location.ml>: pkg_camlp4
<cass_parser.ml*>: syntax_camlp4o,pkg_camlp4.extend
<cass_quotations.ml*>: syntax_camlp4o,pkg_camlp4.quotations,pkg_dyntype
View
@@ -31,27 +31,27 @@ type t =
let get_expr _loc m =
match m with
| <:expr< Css.Exprs [ $e$ ] >> -> <:expr< $e$ >>
- | m -> <:expr< match $m$ with [ Css.Exprs [ e ] -> e | _ -> failwith "elt" ] >>
+ | m -> <:expr< Css.expr $m$ >>
let get_exprs _loc m =
match m with
| <:expr< Css.Exprs $e$ >> -> <:expr< $e$ >>
- | m -> <:expr< match $m$ with [ Css.Exprs e -> e | _ -> failwith "elts" ] >>
+ | m -> <:expr< Css.exprs $m$ >>
let get_props _loc m =
match m with
| <:expr< Css.Props $e$ >> -> <:expr< $e$ >>
- | m -> <:expr< match $m$ with [ Css.Props p -> p | _ -> failwith "props" ] >>
+ | m -> <:expr< Css.props $m$ >>
let get_decls _loc m =
match m with
| <:expr< Css.Decls $e$ >> -> <:expr< $e$ >>
- | m -> <:expr< match $m$ with [ Css.Decls d -> d | _ -> failwith "decls" ] >>
+ | m -> <:expr< Css.decls $m$ >>
let get_string _loc m =
match m with
| <:expr< Css.Exprs [ [Css.Str $e$] ] >> -> <:expr< $e$ >>
- | m -> <:expr< match $m$ with [ Css.Exprs [ [ Css.Str s ] ] -> s | _ -> failwith "string" ] >>
+ | m -> <:expr< Css.string $m$ >>
let rec meta_t _loc = function
| String s ->
View
@@ -18,9 +18,11 @@ open Camlp4.PreCast
let current = ref Loc.ghost
-let set l = current := l
+let set l =
+ current := l
-let get () = !current
+let get () =
+ !current
let shift n =
current := Loc.shift n !current
View
@@ -40,13 +40,7 @@ object
let n, c = destruct_aq s in
let e = AQ.parse_expr _loc c in
begin match n with
- | "expr" ->
- <:expr<
- Css.Exprs [List.flatten (List.map
- (fun e -> match e with [
- Css.Exprs [e] -> e
- | _ -> raise Parsing.Parse_error]) $e$)]
- >>
+ | "expr" -> <:expr< Css.Exprs [List.flatten (List.map Css.expr $e$)] >>
| "prop" -> <:expr< Css.Props $e$ >>
| "" -> e
| t ->
@@ -56,20 +50,19 @@ object
| e -> super#expr e
end
-let parse_quot_string fn loc s =
- Cass_location.set loc;
+let parse_quot_string fn _loc s =
+ Cass_location.set _loc;
let res = fn Cass_lexer.token (Lexing.from_string s) in
- Cass_location.set Loc.ghost;
res
-let expand_expr fn loc _ s =
- let ast = parse_quot_string fn loc s in
- let meta_ast = Cass_ast.meta_t loc ast in
+let expand_expr fn _loc _ s =
+ let ast = parse_quot_string fn _loc s in
+ let meta_ast = Cass_ast.meta_t _loc ast in
aq_expander#expr meta_ast
-let expand_str_item fn loc _ s =
- let exp_ast = expand_expr fn loc None s in
- <:str_item@loc< $exp:exp_ast$ >>
+let expand_str_item fn _loc _ s =
+ let exp_ast = expand_expr fn _loc None s in
+ <:str_item< $exp:exp_ast$ >>
;;
View
83 css.ml
@@ -30,44 +30,69 @@ module Css = struct
| Decls of decl list
| Exprs of expr list
- open Format
+ let props = function
+ | Props p -> p
+ | _ -> raise Parsing.Parse_error
- let rec elt ppf (e : elt) = match e with
- | Str s -> fprintf ppf "%s" s
- | Fun (s,el) -> fprintf ppf "%s(%a)" s exprs el
+ let decls = function
+ | Decls d -> d
+ | _ -> raise Parsing.Parse_error
- and expr ppf (e : expr) = match e with
- | [] -> ()
- | [h] -> fprintf ppf "%a" elt h
- | h::t -> fprintf ppf "%a %a" elt h expr t
+ let exprs = function
+ | Exprs e -> e
+ | _ -> raise Parsing.Parse_error
- and exprs ppf (el : expr list) = match el with
- | [] -> ()
- | [h] -> fprintf ppf "%a" expr h
- | h::t -> fprintf ppf "%a, %a" expr h exprs t
+ let expr = function
+ | Exprs [e] -> e
+ | _ -> raise Parsing.Parse_error
- let prop ppf (n, el) =
- fprintf ppf "\t%s: %a;" n exprs el
+ let string = function
+ | Exprs [[Str s]] -> s
+ | _ -> raise Parsing.Parse_error
- let rec props ppf (pl : prop list) = match pl with
- | [] -> ()
- | h::t -> fprintf ppf "%a\n%a" prop h props t
+ module Output = struct
- let decl ppf (sl, pl) =
- fprintf ppf "%a {\n%a}\n" exprs sl props pl
+ open Format
- let rec decls ppf (dl : decl list) = match dl with
- | [] -> ()
- | h::t -> fprintf ppf "%a\n%a" decl h decls t
+ let rec elt ppf (e : elt) = match e with
+ | Str s -> fprintf ppf "%s" s
+ | Fun (s,el) -> fprintf ppf "%s(%a)" s exprs el
- let t ppf (x : t) = match x with
- | Props pl -> props ppf pl
- | Decls dl -> decls ppf dl
- | Exprs el -> exprs ppf el
+ and expr ppf (e : expr) = match e with
+ | [] -> ()
+ | [h] -> fprintf ppf "%a" elt h
+ | h::t -> fprintf ppf "%a %a" elt h expr t
+
+ and exprs ppf (el : expr list) = match el with
+ | [] -> ()
+ | [h] -> fprintf ppf "%a" expr h
+ | h::t -> fprintf ppf "%a, %a" expr h exprs t
+
+ let prop ppf (n, el) =
+ fprintf ppf "\t%s: %a;" n exprs el
+
+ let rec props ppf (pl : prop list) = match pl with
+ | [] -> ()
+ | h::t -> fprintf ppf "%a\n%a" prop h props t
+
+ let decl ppf (sl, pl) =
+ fprintf ppf "%a {\n%a}\n" exprs sl props pl
+
+ let rec decls ppf (dl : decl list) = match dl with
+ | [] -> ()
+ | h::t -> fprintf ppf "%a\n%a" decl h decls t
+
+ let t ppf (x : t) = match x with
+ | Props pl -> props ppf pl
+ | Decls dl -> decls ppf dl
+ | Exprs el -> exprs ppf el
+
+ end
+
+ let to_string t =
+ Output.t Format.str_formatter t;
+ Format.flush_str_formatter ()
- let to_string elt =
- t str_formatter elt;
- flush_str_formatter ()
end
(* From http://www.webdesignerwall.com/tutorials/cross-browser-css-gradient/ *)
View
10 css.mli
@@ -36,13 +36,21 @@ type t =
val to_string : t -> string
+(** {2 Getters} *)
+
+val expr : t -> expr
+val exprs : t -> expr list
+val decls : t -> decl list
+val props : t -> prop list
+val string : t -> string
+
(** {2 CSS library} *)
val gradient : low:t -> high:t -> t
val top_rounded : t
val bottom_rounded : t
-val rounded: t
+val rounded : t
val box_shadow : t
val text_shadow : t

0 comments on commit 29bbae0

Please sign in to comment.