Permalink
Browse files

Modify CSS.t to be more easy to use. That will allow us to have neste…

…d declarations -- that doesn't work yet.
  • Loading branch information...
1 parent 9824b8c commit 7830b07a4cfbc100c4b2a39810b6db76e316630f @samoht committed Nov 14, 2010
Showing with 186 additions and 148 deletions.
  1. +4 −4 Makefile
  2. +2 −3 _tags
  3. +66 −11 cass_ast.ml
  4. +3 −2 cass_ast.mli
  5. +3 −3 cass_lexer.mll
  6. +21 −44 cass_parser.mly
  7. +9 −8 cass_printer.ml
  8. +12 −6 cass_quotations.ml
  9. +45 −50 css.ml
  10. +18 −16 css.mli
  11. +3 −1 test.ml
View
@@ -9,11 +9,11 @@ css.cmx css.cmo css.cmi
BFILES=$(addprefix _build/,$(FILES))
-STUFF=$(shell ocamlfind query cass -r -format "-I %d %a" -predicates byte)
+INCLS = $(shell ocamlfind query dyntype.syntax -predicates syntax,preprocessor -r -format "-I %d %a") \
all:
ocamlbuild cass.cma cass_top.cmo cass.cmxa
- ocamlbuild -pp "camlp4orf cass.cma" css.cmo css.cmx
+ ocamlbuild -pp "camlp4o $(INCLS) cass.cma" css.cmo css.cmx
install:
ocamlfind install cass META $(BFILES)
@@ -26,11 +26,11 @@ clean:
rm -rf test.exp test.cmo test.cmx test.cmi test.o
test:
- ocamlbuild -pp "camlp4orf cass.cma" test.byte --
+ ocamlbuild -pp "camlp4o $(INCLS) cass.cma" test.byte --
.PHONY: text_exp
test_exp: test.ml
- camlp4of _build/cass.cma test.ml -printer o > test_exp.ml
+ camlp4of $(INCLS) _build/cass.cma test.ml -printer o > test_exp.ml
ocamlc -annot -I _build/ css.cmo test_exp.ml -o test_exp
debug: all
View
@@ -1,5 +1,4 @@
<cass_location.ml>: pkg_camlp4
-<cass_ast.ml*>: pkg_camlp4
<cass_parser.ml*>: syntax_camlp4o,pkg_camlp4.extend
-<cass_quotations.ml*>: syntax_camlp4o,pkg_camlp4.quotations
-<cass_ast.ml*>: syntax_camlp4o,pkg_camlp4.quotations
+<cass_quotations.ml*>: syntax_camlp4o,pkg_camlp4.quotations,pkg_dyntype
+<cass_ast.ml*>: syntax_camlp4o,pkg_camlp4.quotations,pkg_dyntype
View
@@ -16,24 +16,79 @@
open Camlp4.PreCast (* for Ast refs in generated code *)
+(* The raw CSS fragments (after the parsing / before the lifting) *)
type t =
| String of string
| Decl of t * t
| Rule of t * t
| Fun of t * t
| Comma of t * t
- | Seq of t * t
+ | ESeq of t * t (* sequence of elements *)
+ | RSeq of t * t (* sequence of rules/declarations *)
| Nil
-
| Ant of Loc.t * string
+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" ] >>
+
+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" ] >>
+
+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" ] >>
+
+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" ] >>
+
+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" ] >>
+
let rec meta_t _loc = function
- | String s -> <:expr< Css.String $`str:s$ >>
- | Decl (a,b) -> <:expr< Css.Decl ($meta_t _loc a$, $meta_t _loc b$) >>
- | Rule (a,b) -> <:expr< Css.Rule ($meta_t _loc a$, $meta_t _loc b$) >>
- | Fun (a,b) -> <:expr< Css.Fun ($meta_t _loc a$, $meta_t _loc b$) >>
- | Comma (a,b) -> <:expr< Css.Comma ($meta_t _loc a$, $meta_t _loc b$) >>
- | Seq (a,b) -> <:expr< Css.Seq ($meta_t _loc a$, $meta_t _loc b$) >>
- | Nil -> <:expr< Css.Nil >>
-
- | Ant (l, str) -> Ast.ExAnt (l, str)
+ | String s ->
+ <:expr< Css.Exprs [[Css.Str $`str:s$]] >>
+
+ | Decl (a,b) ->
+ let elts = get_exprs _loc (meta_t _loc a) in
+ let props = get_props _loc (meta_t _loc b) in
+ <:expr< Css.Decls [ ($elts$, $props$) ] >>
+
+ | Rule (a,b) ->
+ let name = get_string _loc (meta_t _loc a) in
+ let props = get_exprs _loc (meta_t _loc b) in
+ <:expr< Css.Props [ ($name$, $props$) ] >>
+
+ | Fun (a,b) ->
+ let name = get_string _loc (meta_t _loc a) in
+ let args = get_exprs _loc (meta_t _loc a) in
+ <:expr< Css.Exprs [[Css.Fun ($name$, $args$) ]] >>
+
+ | Comma (a,b) ->
+ let e1 = get_exprs _loc (meta_t _loc a) in
+ let e2 = get_exprs _loc (meta_t _loc b) in
+ <:expr< Css.Exprs ($e1$ @ $e2$) >>
+
+ | ESeq (a,b) ->
+ let e1 = get_expr _loc (meta_t _loc a) in
+ let e2 = get_expr _loc (meta_t _loc b) in
+ <:expr< Css.Exprs [ ($e1$ @ $e2$) ] >>
+
+ | RSeq (a,b) ->
+ let e1 = get_props _loc (meta_t _loc a) in
+ let e2 = get_props _loc (meta_t _loc b) in
+ <:expr< Css.Props ($e1$ @ $e2$) >>
+
+ | Nil ->
+ <:expr< Css.Exprs [[]] >>
+
+ | Ant (l, str) ->
+ Ast.ExAnt (l, str)
View
@@ -16,15 +16,16 @@
open Camlp4.PreCast
+(** Intermediate type for CSS fragments. Produced by the parser and consumed by the lifter *)
type t =
| String of string
| Decl of t * t
| Rule of t * t
| Fun of t * t
| Comma of t * t
- | Seq of t * t
+ | ESeq of t * t (** sequence of elements *)
+ | RSeq of t * t (** sequence of rules and declarations *)
| Nil
-
| Ant of Loc.t * string
val meta_t : Ast.loc -> t -> Ast.expr
View
@@ -50,11 +50,11 @@ rule token = parse
| '=' { debug "="; EQ }
| "/*" { comments lexbuf; token lexbuf }
| eof { debug "EOF"; update lexbuf; EOF }
- | all* as x { debug "%s" x; update lexbuf;
+ | all* as x { update lexbuf;
if x.[String.length x - 1] = ':' then
- PROP (String.sub x 0 (String.length x - 1))
+ (debug "P%s" x; PROP (String.sub x 0 (String.length x - 1)))
else
- STRING x }
+ (debug "%s" x; STRING x) }
and dollar = parse
| ([^ '$']* as str) '$' { update lexbuf; str }
View
@@ -51,65 +51,42 @@
%%
- arg:
- | one EQ one { debug "EQ"; Seq($1, Seq(String "=", $3)) }
- | one LEFT args RIGHT { debug "FUN"; Fun($1, $3) }
- | one arg { debug "SEQ"; Seq($1, $2) }
- | one { $1 }
+ elt:
+ | STRING EQ STRING { debug "EQ"; ESeq(String $1, ESeq(String "=", String $3)) }
+ | STRING EQ DOLLAR { debug "EQ"; ESeq(String $1, ESeq(String "=", Ant (Cass_location.get (), $3))) }
+ | STRING LEFT exprs RIGHT { debug "FUN"; Fun(String $1, $3) }
+ | STRING { debug "STRING(%s)" $1; String $1 }
+ | DOLLAR { debug "EDOLLAR(%s)" $1; Ant (Cass_location.get (), $1) }
;
- args:
- | arg COMMA args { Comma($1, $3) }
- | arg { $1 }
-;
-
- one:
- | STRING { debug "STRING(%s)" $1; String $1 }
- | DOLLAR { debug "DOLLAR(%s)" $1; Ant (Cass_location.get (), $1) }
- ;
-
expr:
- | one LEFT args RIGHT { debug "FUN"; Fun ($1,$3) }
- | one { $1 }
- ;
-
- expr0:
- | expr expr0 { Seq ($1, $2) }
- | expr { $1 }
- ;
+ | elt expr { debug "ESEQ"; ESeq ($1, $2) }
+ | elt { debug "ELT"; $1 }
+;
exprs:
- | expr0 COMMA exprs { debug "COMMA"; Comma ($1, $3) }
- | expr0 { $1 }
- ;
-
- rule:
- | PROP exprs SEMI { debug "RULE(%s)" $1; Rule (String $1, $2) }
- | DOLLAR SEMI { debug "DOLLAR(%s)" $1; Ant (Cass_location.get (), $1) }
- ;
-
- rules:
- | rule rules { debug "SEMI"; Seq($1, $2) }
- | rule { $1 }
+ | expr COMMA exprs { debug "COMMA"; Comma ($1, $3) }
+ | expr { debug "ELTS"; $1 }
;
- decl:
- | exprs OPEN rules CLOSE { debug "DECL"; Decl ($1, $3) }
- | DOLLAR { debug "DOLLAR(%s)" $1; Ant (Cass_location.get (), $1) }
+ prop:
+ | PROP exprs SEMI { debug "PROP(%s)" $1; Rule (String $1, $2) }
+ | DOLLAR SEMI { debug "RDOLLAR(%s)" $1; Ant (Cass_location.get (), $1) }
+ | exprs OPEN props CLOSE { debug "DECL"; Decl ($1, $3) }
+ | DOLLAR { debug "DDOLLAR(%s)" $1; Ant (Cass_location.get (), $1) }
;
- decls:
- | decl decls { debug "SEQ"; Seq ($1, $2) }
- | decl { $1 }
+ props:
+ | prop props { debug "RSEQ"; RSeq ($1, $2) }
+ | prop { debug "PROP"; $1 }
;
all:
- | decls { $1 }
- | rules { $1 }
| exprs { $1 }
+ | props { $1 }
;
main:
- | all EOF { debug "DECL"; newline (); $1 }
+ | all EOF { debug "DECL\n"; newline (); $1 }
;
View
@@ -17,16 +17,17 @@
open Format
open Cass_ast
-(* XXX: improve the formatter *)
let rec t ppf = function
- | String s -> fprintf ppf "%S" s
- | Decl (t1, t2) -> fprintf ppf "%a { %a }" t t1 t t2
- | Rule (t1, t2) -> fprintf ppf "%a : %a;\n" t t1 t t2
- | Fun (t1, t2) -> fprintf ppf "%a(%a)" t t1 t t2
+ | String s -> fprintf ppf "%S" s
+ | Decl (t1, t2) -> fprintf ppf "%a { %a }" t t1 t t2
+ | Rule (t1, t2) -> fprintf ppf "\t%a : %a;\n" t t1 t t2
+ | Fun (t1, t2) -> fprintf ppf "%a(%a)" t t1 t t2
| Comma (t1, Nil) -> t ppf t1
- | Comma (t1, t2) -> fprintf ppf "%a, %a" t t1 t t2
- | Seq (t1, Nil) -> t ppf t1
- | Seq (t1, t2) -> fprintf ppf "%a %a" t t1 t t2
+ | Comma (t1, t2) -> fprintf ppf "%a, %a" t t1 t t2
+ | ESeq (t1, Nil) -> t ppf t1
+ | ESeq (t1, t2) -> fprintf ppf "%a %a" t t1 t t2
+ | RSeq (t1, Nil) -> t ppf t1
+ | RSeq (t1, t2) -> fprintf ppf "%a %a" t t1 t t2
| Nil -> ()
| Ant (_, s) -> fprintf ppf "$%s$" s
View
@@ -40,12 +40,18 @@ object
let n, c = destruct_aq s in
let e = AQ.parse_expr _loc c in
begin match n with
- | "int" -> <:expr< Css.Number (float_of_int $e$) >> (* e is an int *)
- | "flo" -> <:expr< Css.Numner $e$ >> (* e is a float *)
- | "str" -> <:expr< Css.String $e$ >> (* e is a string *)
- | "list" -> <:expr< Css.Seq.t_of_list $e$ >>
- | "alist" -> <:expr< Css.Semi.t_of_list (List.map (fun (str,elt) -> Css.Colon (str, elt)) $e$) >>
- | _ -> e
+ | "expr" ->
+ <:expr<
+ Css.Exprs [List.flatten (List.map
+ (fun e -> match e with [
+ Css.Exprs [e] -> e
+ | _ -> raise Parsing.Parse_error]) $e$)]
+ >>
+ | "prop" -> <:expr< Css.Props $e$ >>
+ | "" -> e
+ | t ->
+ Printf.eprintf "[ERROR] \"%s\" is not a valid tag. Valid tags are [expr|prop]\n" t;
+ Loc.raise _loc Parsing.Parse_error
end
| e -> super#expr e
end
Oops, something went wrong. Retry.

0 comments on commit 7830b07

Please sign in to comment.