ocsigen · Drup · Apr 14, 2016 · Apr 11, 2016 · Apr 11, 2016 · Apr 11, 2016
diff --git a/_oasis b/_oasis
@@ -203,6 +203,20 @@ Test basic_website
   TestTools: basic_website
   Run$: flag(tests)
 
+Executable basic_website_ppx
+  Install: false
+  Build$: flag(tests) && flag(tests)
+  Path: examples/basic_website_ppx
+  MainIs: site_html.ml
+  BuildDepends: tyxml
+  CompiledObject: best
+
+Test basic_website_ppx
+  WorkingDirectory: examples/basic_website_ppx
+  Command: $basic_website_ppx
+  TestTools: basic_website_ppx
+  Run$: flag(tests) && flag(tests)
+
 Executable mini_website
   Install: false
   Build$: flag(tests)

diff --git a/_tags b/_tags
@@ -15,4 +15,4 @@ true: keep_locs
 # Tests use the tyxml ppx
 <test/*.ml>: ppx_tyxml
 
-<examples/mini_website_ppx/*.ml>: ppx_tyxml
+<examples/*_ppx/*.ml>: ppx_tyxml
diff --git a/examples/basic_website_ppx/.merlin b/examples/basic_website_ppx/.merlin
@@ -0,0 +1 @@
+PKG tyxml.ppx
diff --git a/examples/basic_website_ppx/Makefile b/examples/basic_website_ppx/Makefile
@@ -0,0 +1,8 @@
+site_gen := make_site
+
+all:
+	ocamlfind ocamlc site_html.ml -package tyxml.ppx -short-paths -linkpkg -o ${site_gen}
+	./${site_gen}
+
+clean:
+	rm -f *.cmo *.cmt *.cmi ${site_gen} index.html
diff --git a/examples/basic_website_ppx/Readme.md b/examples/basic_website_ppx/Readme.md
@@ -0,0 +1,13 @@
+This is a very simple website in pure tyxml using the ppx syntax extension.
+To generate the website, compile `site_html.ml` and then execute. This can be done with `make`.
+
+Content of this directory:
+- `site_html.ml`: Generates the Html.
+- `Makefile`: Simple rules to create the website. Uses ocamlbuild
+- `main.js` and `home.css` : auxiliary files for the website.
+- `.merlin`: An appropriate merlin file.
+- Readme.md : You are reading it
+
+This website is distributed under the [unlicense][], feel free to use it!
+
+[unlicense]: http://unlicense.org/
diff --git a/examples/basic_website_ppx/home.css b/examples/basic_website_ppx/home.css
@@ -0,0 +1,11 @@
+#links_bar li {
+    margin:1em;
+    padding:0.4em;
+    font-size:large;
+    display:inline;
+    cursor:pointer;
+    border:none;
+    border-radius:0px;
+    transition:.2s linear;
+    text-align:center;
+}
diff --git a/examples/basic_website_ppx/main.js b/examples/basic_website_ppx/main.js
@@ -0,0 +1,6 @@
+"use strict";
+
+
+var handle = document.getElementById("payload");
+
+console.log(handle);
diff --git a/examples/basic_website_ppx/site_html.ml b/examples/basic_website_ppx/site_html.ml
@@ -0,0 +1,69 @@
+open Tyxml
+
+let this_title = Html.pcdata "Your Cool Web Page"
+
+let image_box = [%html
+  "<div id=image_box></div>"
+]
+
+let links_box = [%html {|
+  <ul class=links_bar id=links_bar>
+    <li id=home_click >My Musings</li>
+    <li id=about_click >About Me</li>
+    <li id=blog_posts_click >Blog</li>
+    <li id=hackathons_click >Hackathons</li>
+  </ul>
+|}]
+
+let common_footer = [%html {|
+  <footer id="footer_box">
+    <p>
+      This site was made with <a href=http://ocaml.org>OCaml</a> and <a href=https://www.gnu.org/software/emacs/>emacs</a>
+    </p>
+  </footer>
+|}]
+
+let home_content = [%html
+  "<div><h2>Hello Coder</h2></div>"
+]
+
+let main_payload = [%html
+  "<div id=payload>"[home_content]"</div>"
+]
+
+let common_nav = Html.nav [links_box]
+
+let content_box = [%html
+  "<div id=content_box>"[
+    common_nav;
+    main_payload;
+    common_footer;
+  ]"</div>"
+]
+
+let main_script = [%html
+  "<script src=main.js> </script>"
+]
+
+let home_page_doc = [%html
+  {|<html>
+    <head>
+     <title>|}this_title{|</title>
+     <link rel=stylesheet href="home.css" />
+    </head>
+    <body>|} [ image_box; content_box; main_script ] {|</body>
+    </html>
+|}]
+
+(** The set of pages in your website. *)
+let pages = [("index.html", home_page_doc)]
+
+(** Small code to emit all the pages. *)
+let emit_page (name, page) =
+  Printf.printf "Generating: %s\n" name ;
+  let file_handle = open_out name in
+  let fmt = Format.formatter_of_out_channel file_handle in
+  Html.pp () fmt page;
+  close_out file_handle
+
+let () = List.iter emit_page pages
diff --git a/examples/mini_website_ppx/minihtml.ml b/examples/mini_website_ppx/minihtml.ml
@@ -11,7 +11,13 @@ let mycontent = [%html {|
 let mytitle = Html.pcdata "A Fabulous Web Page"
 
 let mypage = [%html
-  "<html><head><title>"mytitle"</title></head><body>"mycontent"</body></html>"]
+  {|<html>
+     <head>
+       <title>|}mytitle{|</title>
+     </head>
+     <body>"mycontent"</body>
+   </html>
+  |}]
 
 let () =
   let file = open_out "index.html" in

diff --git a/lib/html_sigs.mli b/lib/html_sigs.mli
@@ -704,8 +704,10 @@ module type T = sig
   val dl : ([< | dl_attrib], [< | dl_content_fun], [> | dl]) star
 
   val ol : ([< | ol_attrib], [< | ol_content_fun], [> | ol]) star
+      [@@reflect.element "ol"]
 
   val ul : ([< | ul_attrib], [< | ul_content_fun], [> | ul]) star
+      [@@reflect.element "ul"]
 
   val dd : ([< | dd_attrib], [< | dd_content_fun], [> | dd]) star
 

diff --git a/ppx/ppx_element_content.ml b/ppx/ppx_element_content.ml
@@ -42,17 +42,27 @@ let to_pcdata = function
     end
   | _ -> None
 
+(** Test if the expression is a pcdata containing only whitespaces. *)
+let is_whitespace = function
+  | Pc.Val e -> begin
+      match to_pcdata e with
+      | Some s when String.trim s = "" -> true
+      | _ -> false
+    end
+  | _ -> true
+
 (* Given a list of parse trees representing children of an element, filters out
    all children that consist of applications of [pcdata] to strings containing
    only whitespace. *)
-let filter_whitespace children =
-  children |> List.filter (function
-    | Pc.Val e -> begin
-        match to_pcdata e with
-        | Some s when String.trim s = "" -> false
-        | _ -> true
-      end
-    | _ -> true)
+let filter_whitespace = List.filter (fun e -> not @@ is_whitespace e)
+
+let filter_surrounding_whitespace children =
+  let rec aux = function
+    | [] -> []
+    | h :: t when is_whitespace h -> aux t
+    | l -> List.rev l
+  in
+  aux @@ aux children
 
 (* Given a parse tree and a string [name], checks whether the parse tree is an
    application of a function with name [name]. *)
@@ -93,7 +103,16 @@ let star ~lang ~loc ~name:_ children =
 
 (* Special-cased. *)
 
+let ul ~lang ~loc ~name children =
+  let children = filter_whitespace children in
+  star ~lang ~loc ~name children
+
+let ol ~lang ~loc ~name children =
+  let children = filter_whitespace children in
+  star ~lang ~loc ~name children
+
 let head ~lang ~loc ~name children =
+  let children = filter_whitespace children in
   let title, others = partition (html "title") children in
 
   match title with

diff --git a/ppx/ppx_element_content.mli b/ppx/ppx_element_content.mli
@@ -77,3 +77,13 @@ val fieldset : assembler
 val datalist : assembler
 val details : assembler
 val menu : assembler
+val ul : assembler
+val ol : assembler
+
+(** {1 Misc utilities} *)
+
+(** Remove pcdata containing only whitespace that are at the beginning or the end
+    of the list. *)
+val filter_surrounding_whitespace :
+  Parsetree.expression Ppx_common.value list ->
+  Parsetree.expression Ppx_common.value list
diff --git a/ppx/ppx_tyxml.ml b/ppx/ppx_tyxml.ml
@@ -270,7 +270,12 @@ let markup_to_expr lang loc expr =
       assemble lang children
   in
 
-  match assemble lang [] with
+  let l =
+    Ppx_element_content.filter_surrounding_whitespace @@
+    assemble lang []
+  in
+
+  match l  with
   | [ Val x | Antiquot x ] -> x
   | l -> Ppx_common.list_wrap_value lang loc l
 

diff --git a/test/test_ppx.ml b/test/test_ppx.ml
@@ -61,6 +61,33 @@ let basics = "ppx basics", tyxml_tests Html.[
   [[%html "<html><head><title>foo</title></head> </html>"]],
   [html (head (title (pcdata "foo")) []) (body [])] ;
 
+  "whitespace around html element",
+  [[%html "  <html><head><title>foo</title></head></html>  "]],
+  [html (head (title (pcdata "foo")) []) (body [])] ;
+
+  "whitespace around element",
+  [[%html "   <p></p>   "]],
+  [p []] ;
+
+  "whitespace in element",
+  [[%html "   <p>  </p>   "]],
+  [p [pcdata "  "]] ;
+
+  "whitespace around lists",
+  [%html "   <p></p><span></span>   "],
+  [p [] ; span []] ;
+
+  "whitespace around pcdata",
+  [%html "   bar<p></p>foo   "],
+  [pcdata "   bar" ; p [] ; pcdata "foo   " ] ;
+
+  "whitespace in ul",
+  [[%html "<ul>   <li>foo</li>  <li>bar</li>   </ul>"]],
+  [ul [li [pcdata "foo"] ; li [pcdata "bar"]]] ;
+
+  "whitespace in ol",
+  [[%html "<ol>   <li>foo</li>  <li>bar</li>   </ol>"]],
+  [ol [li [pcdata "foo"] ; li [pcdata "bar"]]] ;
 
 ]