Permalink
Browse files

General improvement to the lexer, the parser, the build system.

Now it is possible to use quotations in css.ml to write library functions (as gradient or rounded).
  • Loading branch information...
1 parent 28d5749 commit 4f290be96b4b0dae879e2a44dc35ccdbd7d2048b @samoht committed Nov 10, 2010
Showing with 117 additions and 106 deletions.
  1. +7 −5 Makefile
  2. +0 −1 _tags
  3. +21 −20 cass_lexer.mll
  4. +14 −6 cass_parser.mly
  5. +2 −0 cass_quotations.ml
  6. +71 −72 css.ml
  7. +2 −2 test.ml
View
12 Makefile
@@ -12,7 +12,8 @@ BFILES=$(addprefix _build/,$(FILES))
STUFF=$(shell ocamlfind query cass -r -format "-I %d %a" -predicates byte)
all:
- ocamlbuild cass.cma cass_top.cmo cass.cmxa css.cmo css.cmx
+ ocamlbuild cass.cma cass_top.cmo cass.cmxa
+ ocamlbuild -pp "camlp4orf cass.cma" css.cmo css.cmx
install:
ocamlfind install cass META $(BFILES)
@@ -25,11 +26,12 @@ clean:
rm -rf test.exp test.cmo test.cmx test.cmi test.o
test:
- ocamlbuild test.byte
- ./test.byte
+ ocamlbuild -pp "camlp4orf cass.cma" test.byte --
-test.exp: test.ml
- camlp4of _build/cass.cma test.ml -printer o > test.exp
+.PHONY: text_exp
+test_exp: test.ml
+ camlp4of _build/cass.cma test.ml -printer o > test_exp.ml
+ ocamlc -annot -I _build/ css.cmo test_exp.ml -o test_exp
debug: all
camlp4of _build/cass.cma test.ml
View
1 _tags
@@ -3,4 +3,3 @@
<cass_parser.ml*>: syntax_camlp4o,pkg_camlp4.extend
<cass_quotations.ml*>: syntax_camlp4o,pkg_camlp4.quotations
<cass_ast.ml*>: syntax_camlp4o,pkg_camlp4.quotations
-<test.ml>: syntax_camlp4o,pkg_cass
View
41 cass_lexer.mll
@@ -32,31 +32,32 @@
Cass_location.newline ()
}
-let all = [^ ' ' '\t' '\r' '\n' ';' ',' '{' '}' '$' '"' '\'']
+let all = [^ ' ' '\t' '\r' '\n' '{' '}' '(' ')' ';' ',' '$' '"' '\'' '=']
(* very very simple HTML lexer *)
rule token = parse
- | [' ' '\t']* { update lexbuf; token lexbuf }
- | '\n' { newline lexbuf; token lexbuf }
- | '{' { debug "{"; update lexbuf; OPEN }
- | '}' { debug "}"; CLOSE }
- | '(' { debug "("; LEFT }
- | ')' { debug ")"; RIGHT }
- | ',' { debug ","; update lexbuf; COMMA }
- | ';' { debug ";"; update lexbuf; SEMI }
- | '$' { debug "$*$"; update lexbuf; DOLLAR (dollar lexbuf) }
- | '"' { debug "\"*\""; update lexbuf; STRING (Printf.sprintf "\"%s\"" (dquote lexbuf)) }
- | '\'' { debug "\'"; update lexbuf; STRING (Printf.sprintf "\"%s\"" (quote lexbuf)) }
- | "/*" { comments lexbuf; token lexbuf }
- | eof { debug "EOF"; update lexbuf; EOF }
- | all* as x { debug "%s" x; update lexbuf;
- if x.[String.length x - 1] = ':' then
- PROP (String.sub x 0 (String.length x - 1))
- else
- STRING x }
+ | [' ' '\t' '\r']* { update lexbuf; token lexbuf }
+ | '\n' { newline lexbuf; token lexbuf }
+ | '{' { debug "{"; update lexbuf; OPEN }
+ | '}' { debug "}"; CLOSE }
+ | '(' { debug "("; LEFT }
+ | ')' { debug ")"; RIGHT }
+ | ',' { debug ","; update lexbuf; COMMA }
+ | ';' { debug ";"; update lexbuf; SEMI }
+ | '$' { debug "$*$"; update lexbuf; DOLLAR (dollar lexbuf) }
+ | '"' { debug "\"*\""; update lexbuf; STRING (Printf.sprintf "\"%s\"" (dquote lexbuf)) }
+ | '\'' { debug "\'"; update lexbuf; STRING (Printf.sprintf "\"%s\"" (quote lexbuf)) }
+ | '=' { debug "="; EQ }
+ | "/*" { comments lexbuf; token lexbuf }
+ | eof { debug "EOF"; update lexbuf; EOF }
+ | all* as x { debug "%s" x; update lexbuf;
+ if x.[String.length x - 1] = ':' then
+ PROP (String.sub x 0 (String.length x - 1))
+ else
+ STRING x }
and dollar = parse
- | ([^ '$']* as str) '$' { update lexbuf; str }
+ | ([^ '$']* as str) '$' { update lexbuf; Printf.eprintf "[LEXER] %s\n" str; str }
and dquote = parse
| ([^ '"']* as str) '"' { update lexbuf; str }
View
20 cass_parser.mly
@@ -33,9 +33,10 @@
Printf.kprintf (fun s -> ()) fmt
%}
-%token COMMA SEMI OPEN CLOSE EOF LEFT RIGHT
+%token COMMA SEMI OPEN CLOSE EOF LEFT RIGHT EQ
%token <string> STRING DOLLAR PROP
+%left EQ
%left COMMA
%left SEMI
%left OPEN CLOSE
@@ -50,10 +51,17 @@
%%
+ 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 }
+;
+
args:
- | one COMMA args { Comma ($1, $3) }
- | one { $1 }
- ;
+ | arg COMMA args { Comma($1, $3) }
+ | arg { $1 }
+;
one:
| STRING { debug "STRING(%s)" $1; String $1 }
@@ -76,7 +84,7 @@
;
rule:
- | PROP exprs SEMI { debug "COLON"; Rule (String $1, $2) }
+ | PROP exprs SEMI { debug "RULE(%s)" $1; Rule (String $1, $2) }
| DOLLAR SEMI { debug "DOLLAR(%s)" $1; Ant (Cass_location.get (), $1) }
;
@@ -86,7 +94,7 @@
;
decl:
- | exprs OPEN rules CLOSE { debug "COLON"; Decl ($1, $3) }
+ | exprs OPEN rules CLOSE { debug "DECL"; Decl ($1, $3) }
| DOLLAR { debug "DOLLAR(%s)" $1; Ant (Cass_location.get (), $1) }
;
View
2 cass_quotations.ml
@@ -22,6 +22,8 @@ module AQ = Syntax.AntiquotSyntax
let destruct_aq s =
try
let pos = String.index s ':' in
+ let space = String.index s ' ' in
+ if space < pos then raise Not_found;
let len = String.length s in
let name = String.sub s 0 pos
and code = String.sub s (pos + 1) (len - pos - 1) in
View
143 css.ml
@@ -14,88 +14,87 @@
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)
-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
- | Nil
+module Css = struct
+ 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
+ | Nil
-module Comma = struct
- let rec t_of_list = function
- | [] -> Nil
- | [e] -> e
- | e::es -> Comma (e, t_of_list es)
+ module Comma = struct
+ let rec t_of_list = function
+ | [] -> Nil
+ | [e] -> e
+ | e::es -> Comma (e, t_of_list es)
- let rec list_of_t x acc =
- match x with
- | Nil -> acc
- | Comma (e1, e2) -> list_of_t e1 (list_of_t e2 acc)
- | e -> e :: acc
-end
+ let rec list_of_t x acc =
+ match x with
+ | Nil -> acc
+ | Comma (e1, e2) -> list_of_t e1 (list_of_t e2 acc)
+ | e -> e :: acc
+ end
-module Seq = struct
- let rec t_of_list = function
- | [] -> Nil
- | [e] -> e
- | e::es -> Seq (e, t_of_list es)
+ module Seq = struct
+ let rec t_of_list = function
+ | [] -> Nil
+ | [e] -> e
+ | e::es -> Seq (e, t_of_list es)
- let rec list_of_t x acc =
- match x with
- | Nil -> acc
- | Seq (e1, e2) -> list_of_t e1 (list_of_t e2 acc)
- | e -> e :: acc
-end
+ let rec list_of_t x acc =
+ match x with
+ | Nil -> acc
+ | Seq (e1, e2) -> list_of_t e1 (list_of_t e2 acc)
+ | e -> e :: acc
+ end
-open Printf
-open Format
+ open Printf
+ open Format
-(* XXX: fix the formatter *)
-let rec t ppf = function
- | String s -> fprintf ppf "%s" s
- | Decl (t1, t2) -> fprintf ppf "%a {\n%a}\n" 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
+ (* XXX: fix the formatter *)
+ let rec t ppf = function
+ | String s -> fprintf ppf "%s" s
+ | Decl (t1, t2) -> fprintf ppf "%a {\n%a}\n" 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
+ | 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
+ | Seq (t1, Nil) -> t ppf t1
+ | Seq (t1, t2) -> fprintf ppf "%a %a" t t1 t t2
- | Nil -> ()
+ | Nil -> ()
+
+ let to_string t1 =
+ t str_formatter t1;
+ flush_str_formatter ()
+end
-let to_string t1 =
- t str_formatter t1;
- flush_str_formatter ()
+open Css
(* From http://www.webdesignerwall.com/tutorials/cross-browser-css-gradient/ *)
-let gradient ~default ~low ~high =
- let rule p k = Rule (String p, k) in
- let rules = [
- rule "background" default; (* for non-css3 browsers *)
- rule "filter"
- (Fun
- (String "progid:DXImageTransform.Microsoft.gradient",
- Comma( Seq(String "startColorstr=", high),
- Seq(String "endColorstr=", low)))); (* for IE *)
-
- rule "background"
- (Fun (String "-webkit-gradient",
- Comma.t_of_list
- [ String "linear";
- Seq (String "left", String "top");
- Seq (String "left", String "bottom");
- Fun (String "from", high);
- Fun (String "to", low)])); (* for webkit browsers *)
+let gradient ~(low : t) ~(high : t) : t =
+ let r = <:css<
+ background: $low$; /* for non-css3 browsers */
+ filter: progid:DXImageTransform.Microsoft.gradient(startColorstr=$high$, endColorstr=$low$); /* for IE */
+ background: -webkit-gradient(linear, left top, left bottom, from($high$), to($low$)); /* for webkit browsers */
+ background: -moz-linear-gradient(top, $high$, $low$); /* for firefox 3.6+ */
+ >> in
+
+Printf.eprintf "[GRADIENT]: %s\n" (to_string r); r
- rule "background"
- (Fun (String "-moz-linear-gradient",
- Comma.t_of_list
- [ String "top";
- high;
- low ])); (* for firefox 3.6+ *)
- ] in
- Seq.t_of_list rules
+let rounded : t =
+ <:css<
+ text-shadow: 0 1px 1px rgba(0,0,0,.3);
+ -webkit-border-radius: .5em;
+ -moz-border-radius: .5em;
+ border-radius: .5em;
+ -webkit-box-shadow: 0 1px 2px rgba(0,0,0,.2);
+ -moz-box-shadow: 0 1px 2px rgba(0,0,0,.2);
+ box-shadow: 0 1px 2px rgba(0,0,0,.2);
+ >>
+
+include Css
View
4 test.ml
@@ -9,8 +9,8 @@ let props = <:css<
let c2 = <:css<
body { $props$;
font: "helvetica neue", "helvetica", "arial", sans-serif;
- $Css.gradient color1 color1 color2$;
-}
+ $Css.gradient ~low:color1 ~high:color2$;
+ }
>>
let s = Css.to_string c2

0 comments on commit 4f290be

Please sign in to comment.