diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000000..64d047218d --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,32 @@ +version=0.19.0 +break-cases = fit +break-collection-expressions = fit-or-vertical +break-fun-decl = wrap +break-fun-sig = wrap +break-infix = wrap +break-infix-before-func = false +break-sequences = false +break-separators = before +break-string-literals = never +break-struct = force +cases-matching-exp-indent = compact +doc-comments = after-when-possible +dock-collection-brackets = false +indicate-multiline-delimiters = no +infix-precedence = indent +let-and = compact +let-binding-spacing = compact +module-item-spacing = compact +parens-tuple = multi-line-only +parens-tuple-patterns = multi-line-only +sequence-style = terminator +sequence-blank-line = compact +single-case = compact +type-decl = compact +if-then-else = keyword-first +field-space = loose +space-around-arrays = false +space-around-records = false +space-around-lists = false +space-around-variants = false +ocp-indent-compat = true diff --git a/build/build.ml b/build/build.ml index 50472ccf59..5f6b27f80f 100644 --- a/build/build.ml +++ b/build/build.ml @@ -1,7 +1,8 @@ open Ocamlbuild_plugin module Pack = Ocamlbuild_pack -let best = if Sys.command "command -v ocamlopt > /dev/null" = 0 then "native" else "byte" +let best = + if Sys.command "command -v ocamlopt > /dev/null" = 0 then "native" else "byte" module Conf = struct let server_dir = "server" @@ -10,63 +11,71 @@ module Conf = struct end module Intern = struct - - let with_eliom_ppx = Some begin function - | `Client -> "src/ppx/ppx_eliom_client_ex." ^ best - | `Server -> "src/ppx/ppx_eliom_server_ex." ^ best - end + let with_eliom_ppx = + Some + (function + | `Client -> "src/ppx/ppx_eliom_client_ex." ^ best + | `Server -> "src/ppx/ppx_eliom_server_ex." ^ best) let with_package = function | "eliom.ppx.type" -> "pkg_ppx_eliom_types" - | "eliom.ppx.client" - | "eliom.ppx.server" - | "eliom.syntax.predef" - | "eliom.client" - | "eliom.server" -> (* do noting in this case *) "pkg_dummy" + | "eliom.ppx.client" | "eliom.ppx.server" | "eliom.syntax.predef" + | "eliom.client" | "eliom.server" -> + (* do noting in this case *) "pkg_dummy" | _ -> assert false end -module Eliom_plugin = Ocamlbuild_eliom.MakeIntern(Intern)(Conf) - -let _ = dispatch (fun x -> - Eliom_plugin.dispatcher x; - match x with - | After_rules -> - Doc.init (); - - let link source dest = - rule (Printf.sprintf "%s -> %s" source dest) ~dep:source ~prod:dest - (fun env _ -> Cmd (S [A"ln"; A"-f";P (env source); P (env dest)])) in - - (* add I pflag *) - pflag [ "ocaml"; "compile"] "I" (fun x -> S[A"-I"; A x]); - pflag [ "ocaml"; "infer_interface"] "I" (fun x -> S[A"-I"; A x]); - pflag [ "ocaml"; "doc"] "I" (fun x -> S[A"-I"; A x]); +module Eliom_plugin = Ocamlbuild_eliom.MakeIntern (Intern) (Conf) - (* add syntax extension *) - let add_syntax name path = - let bytes_dep = Findlib.(link_flags_byte [query "bytes"]) in - (* hack : not dep when "compile" to avoid the extension syntax to be link with binaries *) - (* the dep with ocamldep make sure the extension syntax is compiled before *) - flag ["ocaml";"compile";"pkg_"^name] (S [A "-ppx" ;P (path ^ name ^ "_ex." ^ best) ]); - flag_and_dep ["ocaml";"ocamldep";"pkg_"^name] (S [A "-ppx" ;P (path ^ name ^ "_ex." ^ best) ]); - flag_and_dep ["ocaml";"infer_interface";"pkg_"^name] (S [A "-ppx" ;P (path ^ name ^ "_ex." ^ best) ]); - flag_and_dep ["doc";"pkg_"^name] (S [A "-ppx" ;P (path ^ name ^ "_ex." ^ best) ]) in - - add_syntax "ppx_eliom_utils" "src/ppx/"; - add_syntax "ppx_eliom_types" "src/ppx/"; - - (* link executable aliases *) - let link_exec f t = - link (Printf.sprintf "src/tools/%s.byte" f) (Printf.sprintf "src/tools/%s.byte" t); - link (Printf.sprintf "src/tools/%s.native" f) (Printf.sprintf "src/tools/%s.native" t); - in - List.iter (link_exec "eliomc") [ "eliomopt";"eliomcp";"js_of_eliom"]; - link_exec "distillery" "eliom-distillery"; - | _ -> ()) +let _ = + dispatch (fun x -> + Eliom_plugin.dispatcher x; + match x with + | After_rules -> + Doc.init (); + let link source dest = + rule (Printf.sprintf "%s -> %s" source dest) ~dep:source ~prod:dest + (fun env _ -> + Cmd (S [A "ln"; A "-f"; P (env source); P (env dest)])) + in + (* add I pflag *) + pflag ["ocaml"; "compile"] "I" (fun x -> S [A "-I"; A x]); + pflag ["ocaml"; "infer_interface"] "I" (fun x -> S [A "-I"; A x]); + pflag ["ocaml"; "doc"] "I" (fun x -> S [A "-I"; A x]); + (* add syntax extension *) + let add_syntax name path = + let bytes_dep = Findlib.(link_flags_byte [query "bytes"]) in + (* hack : not dep when "compile" to avoid the extension syntax to be link with binaries *) + (* the dep with ocamldep make sure the extension syntax is compiled before *) + flag + ["ocaml"; "compile"; "pkg_" ^ name] + (S [A "-ppx"; P (path ^ name ^ "_ex." ^ best)]); + flag_and_dep + ["ocaml"; "ocamldep"; "pkg_" ^ name] + (S [A "-ppx"; P (path ^ name ^ "_ex." ^ best)]); + flag_and_dep + ["ocaml"; "infer_interface"; "pkg_" ^ name] + (S [A "-ppx"; P (path ^ name ^ "_ex." ^ best)]); + flag_and_dep ["doc"; "pkg_" ^ name] + (S [A "-ppx"; P (path ^ name ^ "_ex." ^ best)]) + in + add_syntax "ppx_eliom_utils" "src/ppx/"; + add_syntax "ppx_eliom_types" "src/ppx/"; + (* link executable aliases *) + let link_exec f t = + link + (Printf.sprintf "src/tools/%s.byte" f) + (Printf.sprintf "src/tools/%s.byte" t); + link + (Printf.sprintf "src/tools/%s.native" f) + (Printf.sprintf "src/tools/%s.native" t) + in + List.iter (link_exec "eliomc") ["eliomopt"; "eliomcp"; "js_of_eliom"]; + link_exec "distillery" "eliom-distillery" + | _ -> ()) let _ = - Options.make_links:=false; + Options.make_links := false; Options.plugin := false; Options.use_ocamlfind := true; Ocamlbuild_unix_plugin.setup (); diff --git a/build/doc.ml b/build/doc.ml index b5e2b5d153..cdd3d49054 100644 --- a/build/doc.ml +++ b/build/doc.ml @@ -18,39 +18,37 @@ let ocamldoc_man tags deps docout docdir = let init_wikidoc () = try let wikidoc_dir = - let base = Ocamlbuild_pack.My_unix.run_and_read "ocamlfind query wikidoc" in + let base = + Ocamlbuild_pack.My_unix.run_and_read "ocamlfind query wikidoc" + in String.sub base 0 (String.length base - 1) in - Ocamlbuild_pack.Rule.rule "ocamldoc: document ocaml project odocl & *odoc -> wikidocdir" - ~insert:`top - ~prod:"%.wikidocdir/index.wiki" - ~stamp:"%.wikidocdir/wiki.stamp" - ~dep:"%.odocl" + ~insert:`top ~prod:"%.wikidocdir/index.wiki" + ~stamp:"%.wikidocdir/wiki.stamp" ~dep:"%.odocl" (Ocamlbuild_pack.Ocaml_tools.document_ocaml_project - ~ocamldoc:ocamldoc_wiki - "%.odocl" "%.wikidocdir/index.wiki" "%.wikidocdir"); - flag ["wikidoc"] & S[A"-colorize-code";A"-i";A wikidoc_dir;A"-g";A"odoc_wiki.cma"]; - pflag ["wikidoc"] "subproject" (fun sub -> S [A"-passopt";A "-subproject"; A sub]) - - with Failure e -> () (* Silently fail if the package wikidoc isn't available *) + ~ocamldoc:ocamldoc_wiki "%.odocl" "%.wikidocdir/index.wiki" + "%.wikidocdir"); + flag ["wikidoc"] + & S [A "-colorize-code"; A "-i"; A wikidoc_dir; A "-g"; A "odoc_wiki.cma"]; + pflag ["wikidoc"] "subproject" (fun sub -> + S [A "-passopt"; A "-subproject"; A sub]) + with Failure e -> () +(* Silently fail if the package wikidoc isn't available *) let init_mandoc () = Ocamlbuild_pack.Rule.rule - "ocamldoc: document ocaml project odocl & *odoc -> mandocdir" - ~insert:`top - ~prod:"%.mandocdir/man.%(ext)" - ~stamp:"%.mandocdir/man.%(ext).stamp" + "ocamldoc: document ocaml project odocl & *odoc -> mandocdir" ~insert:`top + ~prod:"%.mandocdir/man.%(ext)" ~stamp:"%.mandocdir/man.%(ext).stamp" ~dep:"%.odocl" - (Ocamlbuild_pack.Ocaml_tools.document_ocaml_project - ~ocamldoc:ocamldoc_man + (Ocamlbuild_pack.Ocaml_tools.document_ocaml_project ~ocamldoc:ocamldoc_man "%.odocl" "%.mandocdir/man.%(ext)" "%.mandocdir"); - pflag ["apiref"] "man_ext" (fun ext -> S[A"-man-mini";A "-man-section"; A ext; A"-man-suffix";A ext]) - + pflag ["apiref"] "man_ext" (fun ext -> + S [A "-man-mini"; A "-man-section"; A ext; A "-man-suffix"; A ext]) let init () = init_wikidoc (); init_mandoc (); (* ocamldoc intro *) - pflag_and_dep ["doc"] "with_intro" (fun f -> S [A "-intro"; P f]); + pflag_and_dep ["doc"] "with_intro" (fun f -> S [A "-intro"; P f]) diff --git a/pkg/build.ml b/pkg/build.ml index c5e764031d..955f7a0acb 100755 --- a/pkg/build.ml +++ b/pkg/build.ml @@ -1,36 +1,38 @@ #!/usr/bin/env ocaml -#directory "pkg";; -#use "topkg.ml";; + +#directory "pkg" + +#use "topkg.ml" + #use "filelist.ml" (* DEBUG ONLY *) -let nothing_should_be_rebuilt=false +let nothing_should_be_rebuilt = false + let except = function (* cmxs are regerated every time ( bug in ocamlbuild rule) *) | ".cmxs" when nothing_should_be_rebuilt -> false | _ -> true (* END *) -let exts_syntax = List.filter except [".cmo";".cmx";".cma";".cmxa";".cmxs";".a"] +let exts_syntax = + List.filter except [".cmo"; ".cmx"; ".cma"; ".cmxa"; ".cmxs"; ".a"] + let exts_modlib = List.filter except Exts.module_library let exts_lib = List.filter except Exts.library let _ = list_to_file "src/lib/client/client.mllib" client_mllib; list_to_file "src/lib/client/api.odocl" client_api; - list_to_file "src/lib/server/server.mllib" server_mllib; list_to_file "src/lib/server/server.mldylib" server_mllib; list_to_file "src/lib/server/api.odocl" server_api; - list_to_file "src/ocamlbuild/ocamlbuild.mllib" ocamlbuild_mllib; list_to_file "src/ocamlbuild/ocamlbuild.mldylib" ocamlbuild_mllib; list_to_file "src/ocamlbuild/api.odocl" ocamlbuild_api; - list_to_file "src/ppx/ppx.mllib" ppx_mllib; list_to_file "src/ppx/ppx.mldylib" ppx_mllib; list_to_file "src/ppx/api.odocl" ppx_api; - list_to_file "src/ppx/ppx.mllib" ppx_mllib; list_to_file "src/ppx/ppx.mldylib" ppx_mllib; list_to_file "src/ppx/api.odocl" ppx_api @@ -38,80 +40,91 @@ let _ = let spf = Printf.sprintf let nothing = - if nothing_should_be_rebuilt - then "-nothing-should-be-rebuilt" - else "" + if nothing_should_be_rebuilt then "-nothing-should-be-rebuilt" else "" let best = if Env.native then "native" else "byte" -let builder = `Other ("_build/build/build." ^ best,"_build") - +let builder = `Other ("_build/build/build." ^ best, "_build") let with_man3 = Env.bool "manpage" let () = - Pkg.describe "eliom" ~builder ([ - (* META *) - Pkg.lib "pkg/META"; - - (* MANPAGE *) - Pkg.man ~dst:"man1/eliomc.1" "pkg/man/eliomc.1"; - Pkg.man ~dst:"man1/eliomcp.1" "pkg/man/eliomc.1"; - Pkg.man ~dst:"man1/eliomopt.1" "pkg/man/eliomc.1"; - Pkg.man ~dst:"man1/eliomdep.1" "pkg/man/eliomc.1"; - Pkg.man ~dst:"man1/js_of_eliom.1" "pkg/man/eliomc.1"; - Pkg.man ~dst:"man1/eliom-distillery.1" "pkg/man/eliom-distillery.1"; - - Pkg.man ~cond:with_man3 ~dst:"man3/%.3oc" ~target:"src/lib/client/api.mandocdir/man.3oc" "src/lib/client/api.mandocdir/%.3oc"; - Pkg.man ~cond:with_man3 ~dst:"man3/%.3os" ~target:"src/lib/server/api.mandocdir/man.3os" "src/lib/server/api.mandocdir/%.3os"; - Pkg.man ~cond:with_man3 ~dst:"man3/%.3o" ~target:"src/ocamlbuild/api.mandocdir/man.3o" "src/ocamlbuild/api.mandocdir/%.3o"; - Pkg.man ~cond:with_man3 ~dst:"man3/%.3o" ~target:"src/ppx/api.mandocdir/man.3o" "src/ppx/api.mandocdir/%.3o"; - - (* TOOLS *) - Pkg.bin ~auto:true "src/tools/eliomc"; - Pkg.bin ~auto:true "src/tools/eliomcp"; - Pkg.bin ~auto:true "src/tools/eliomdep"; - Pkg.bin ~auto:true "src/tools/eliomopt"; - Pkg.bin ~auto:true "src/tools/js_of_eliom"; - Pkg.bin ~auto:true "src/tools/eliomdoc"; - Pkg.bin ~auto:true "src/tools/eliompp"; - Pkg.bin ~auto:true ~dst:"eliom-distillery" "src/tools/distillery"; - Pkg.bin ~auto:true "src/ocamlbuild/eliombuild"; - - Pkg.lib ~exts:exts_modlib ~dst:"ocamlbuild/ocamlbuild_eliom" "src/ocamlbuild/ocamlbuild_eliom"; - - (* PPX *) - Pkg.lib ~exts:Exts.module_library ~dst:"ppx/ppx_eliom" "src/ppx/ppx_eliom"; - Pkg.lib ~exts:Exts.module_library ~dst:"ppx/ppx_eliom_client" "src/ppx/ppx_eliom_client"; - Pkg.lib ~exts:Exts.module_library ~dst:"ppx/ppx_eliom_type" "src/ppx/ppx_eliom_type"; - Pkg.lib ~exts:Exts.module_library ~dst:"ppx/ppx_eliom_server" "src/ppx/ppx_eliom_server"; - - Pkg.bin ~auto:true ~dst:"ppx_eliom_client" "src/ppx/ppx_eliom_client_ex" ; - Pkg.bin ~auto:true ~dst:"ppx_eliom_server" "src/ppx/ppx_eliom_server_ex" ; - Pkg.bin ~auto:true ~dst:"ppx_eliom_types" "src/ppx/ppx_eliom_types_ex" - - ] @ ( + Pkg.describe "eliom" ~builder + ([ (* META *) + Pkg.lib "pkg/META" + ; (* MANPAGE *) + Pkg.man ~dst:"man1/eliomc.1" "pkg/man/eliomc.1" + ; Pkg.man ~dst:"man1/eliomcp.1" "pkg/man/eliomc.1" + ; Pkg.man ~dst:"man1/eliomopt.1" "pkg/man/eliomc.1" + ; Pkg.man ~dst:"man1/eliomdep.1" "pkg/man/eliomc.1" + ; Pkg.man ~dst:"man1/js_of_eliom.1" "pkg/man/eliomc.1" + ; Pkg.man ~dst:"man1/eliom-distillery.1" "pkg/man/eliom-distillery.1" + ; Pkg.man ~cond:with_man3 ~dst:"man3/%.3oc" + ~target:"src/lib/client/api.mandocdir/man.3oc" + "src/lib/client/api.mandocdir/%.3oc" + ; Pkg.man ~cond:with_man3 ~dst:"man3/%.3os" + ~target:"src/lib/server/api.mandocdir/man.3os" + "src/lib/server/api.mandocdir/%.3os" + ; Pkg.man ~cond:with_man3 ~dst:"man3/%.3o" + ~target:"src/ocamlbuild/api.mandocdir/man.3o" + "src/ocamlbuild/api.mandocdir/%.3o" + ; Pkg.man ~cond:with_man3 ~dst:"man3/%.3o" + ~target:"src/ppx/api.mandocdir/man.3o" "src/ppx/api.mandocdir/%.3o" + ; (* TOOLS *) + Pkg.bin ~auto:true "src/tools/eliomc" + ; Pkg.bin ~auto:true "src/tools/eliomcp" + ; Pkg.bin ~auto:true "src/tools/eliomdep" + ; Pkg.bin ~auto:true "src/tools/eliomopt" + ; Pkg.bin ~auto:true "src/tools/js_of_eliom" + ; Pkg.bin ~auto:true "src/tools/eliomdoc" + ; Pkg.bin ~auto:true "src/tools/eliompp" + ; Pkg.bin ~auto:true ~dst:"eliom-distillery" "src/tools/distillery" + ; Pkg.bin ~auto:true "src/ocamlbuild/eliombuild" + ; Pkg.lib ~exts:exts_modlib ~dst:"ocamlbuild/ocamlbuild_eliom" + "src/ocamlbuild/ocamlbuild_eliom" + ; (* PPX *) + Pkg.lib ~exts:Exts.module_library ~dst:"ppx/ppx_eliom" + "src/ppx/ppx_eliom" + ; Pkg.lib ~exts:Exts.module_library ~dst:"ppx/ppx_eliom_client" + "src/ppx/ppx_eliom_client" + ; Pkg.lib ~exts:Exts.module_library ~dst:"ppx/ppx_eliom_type" + "src/ppx/ppx_eliom_type" + ; Pkg.lib ~exts:Exts.module_library ~dst:"ppx/ppx_eliom_server" + "src/ppx/ppx_eliom_server" + ; Pkg.bin ~auto:true ~dst:"ppx_eliom_client" "src/ppx/ppx_eliom_client_ex" + ; Pkg.bin ~auto:true ~dst:"ppx_eliom_server" "src/ppx/ppx_eliom_server_ex" + ; Pkg.bin ~auto:true ~dst:"ppx_eliom_types" "src/ppx/ppx_eliom_types_ex" ] (* CLIENT LIBS *) - Pkg.lib ~dst:"client/client" ~exts:[".cma"] "src/lib/client/client" :: - Pkg.lib ~dst:"client/eliom_client_main.cmo" "src/lib/client/eliom_client_main.cmo" :: - Pkg.lib ~dst:"client/eliom_client.js" "src/lib/client/eliom_client.js" :: - Pkg.lib ~dst:"client/libeliom_stubs.a" "src/lib/client/libeliom_stubs.a" :: - Pkg.stublibs "src/lib/client/dlleliom_stubs.so" :: - List.map (fun x -> Pkg.lib ~dst:(spf "client/%s" x) (spf "src/lib/client/%s" x)) client_extra - ) @ ( + @ Pkg.lib ~dst:"client/client" ~exts:[".cma"] "src/lib/client/client" + :: Pkg.lib ~dst:"client/eliom_client_main.cmo" + "src/lib/client/eliom_client_main.cmo" + :: Pkg.lib ~dst:"client/eliom_client.js" "src/lib/client/eliom_client.js" + :: Pkg.lib ~dst:"client/libeliom_stubs.a" + "src/lib/client/libeliom_stubs.a" + :: Pkg.stublibs "src/lib/client/dlleliom_stubs.so" + :: List.map + (fun x -> + Pkg.lib ~dst:(spf "client/%s" x) (spf "src/lib/client/%s" x)) + client_extra (* SERVER LIBS *) - Pkg.lib ~dst:"server/monitor/eliom_monitor" ~exts:Exts.module_library "src/lib/server/monitor/eliom_monitor" :: - Pkg.lib ~dst:"server/monitor/eliom_monitor_main" ~exts:Exts.module_library "src/lib/server/monitor/eliom_monitor_main" :: - Pkg.lib ~dst:"server/server" ~exts:exts_lib "src/lib/server/server" :: - List.map (fun x -> Pkg.lib ~dst:(spf "server/%s" x) (spf "src/lib/server/%s" x)) server_extra - ) @ [ - (* MISC *) - - Pkg.doc "README.md"; - Pkg.doc "CHANGES"; - Pkg.etc "pkg/etc/mime.types" - ] @ ( - List.flatten ( - List.map (fun (name,files) -> - List.map (fun file -> - Pkg.lib ~dst:(spf "templates/%s/%s" name file) (spf "%s/%s/%s" templates_dir name file) - ) files) templates_files ) - )) + @ Pkg.lib ~dst:"server/monitor/eliom_monitor" ~exts:Exts.module_library + "src/lib/server/monitor/eliom_monitor" + :: Pkg.lib ~dst:"server/monitor/eliom_monitor_main" + ~exts:Exts.module_library "src/lib/server/monitor/eliom_monitor_main" + :: Pkg.lib ~dst:"server/server" ~exts:exts_lib "src/lib/server/server" + :: List.map + (fun x -> + Pkg.lib ~dst:(spf "server/%s" x) (spf "src/lib/server/%s" x)) + server_extra + @ [ (* MISC *) + Pkg.doc "README.md" + ; Pkg.doc "CHANGES" + ; Pkg.etc "pkg/etc/mime.types" ] + @ List.flatten + (List.map + (fun (name, files) -> + List.map + (fun file -> + Pkg.lib + ~dst:(spf "templates/%s/%s" name file) + (spf "%s/%s/%s" templates_dir name file)) + files) + templates_files)) diff --git a/pkg/filelist.ml b/pkg/filelist.ml index 40559d2af0..05b8adb7c4 100644 --- a/pkg/filelist.ml +++ b/pkg/filelist.ml @@ -1,212 +1,181 @@ -type descr = { - interface_only : string list; - interface : string list; - internal : string list; -} - -let server = { - interface_only = [ - "eliom_content_sigs"; - "eliom_form_sigs"; - "eliom_parameter_sigs"; - "eliom_registration_sigs"; - "eliom_service_sigs"; - "eliom_shared_sigs"; - ]; - interface = [ - "eliom_bus"; - "eliom_client_value"; - "eliom_syntax"; - "eliom_client"; - "eliom_comet"; - "eliom_common"; - "eliom_config"; - "eliom_content"; - "eliom_extension"; - "eliom_lib"; - "eliom_mkreg"; - "eliom_notif"; - "eliom_parameter"; - "eliom_react"; - "eliom_shared"; - "eliom_cscache"; - "eliom_reference"; - "eliom_registration"; - "eliom_request_info"; - "eliom_service"; - "eliom_state"; - "eliom_tools"; - "eliom_types"; - "eliom_uri"; - "eliom_wrap"; - ]; - internal = [ - "eliom_comet_base"; - "eliom_common_base"; - "eliom_runtime"; - "eliom_content_"; - "eliom_content_core"; - "eliom_cookies_base"; - "eliom_error_pages"; - "eliom_form"; - "eliom_lazy"; - "eliom_lib_base"; - "eliom_parameter_base"; - "eliom_process"; - "eliom_service_base"; - "eliom_route"; - "eliom_route_base"; - "eliom_shared_content"; - "eliom_types_base"; - "eliom_client_main"; - "eliommod"; - "eliommod_cli"; - "eliommod_cookies"; - "eliommod_datasess"; - "eliommod_gc"; - "eliommod_pagegen"; - "eliommod_parameters"; - "eliommod_persess"; - "eliommod_sersess"; - "eliommod_sessadmin"; - "eliommod_sessexpl"; - "eliommod_sessiongroups"; - "eliommod_timeouts"; - ] -} -let client = { - interface_only = [ - "eliom_content_sigs"; - "eliom_form_sigs"; - "eliom_parameter_sigs"; - "eliom_registration_sigs"; - "eliom_service_sigs"; - "eliom_shared_sigs"; - ]; - interface = [ - "eliom_bus"; - "eliom_client_value"; - "eliom_client_core"; - "eliom_client"; - "eliom_comet"; - "eliom_config"; - "eliom_content"; - "eliom_content_core"; - "eliom_lazy"; - "eliom_lib"; - "eliom_parameter"; - "eliom_react"; - "eliom_shared"; - "eliom_cscache"; - "eliom_registration"; - "eliom_service"; - "eliom_tools"; - "eliom_types"; - "eliom_unwrap"; - "eliom_uri"; - ]; - internal = [ - "eliom_comet_base"; - "eliom_common"; - "eliom_common_base"; - "eliom_runtime"; - "eliom_content_"; - "eliom_cookies_base"; - "eliom_form"; - "eliom_lib_base"; - "eliom_parameter_base"; - "eliom_process"; - "eliom_request"; - "eliom_request_info"; - "eliom_service_base"; - "eliom_route"; - "eliom_route_base"; - "eliom_shared_content"; - "eliom_types_base"; - "eliommod_cookies"; - "eliommod_dom"; - "eliommod_parameters"; - ]; -} - -let server_ext = { - interface_only = []; - interface = [ - "atom_feed"; - "eliom_atom"; - "eliom_openid"; - "eliom_s2s"]; - internal = [] -} - -let ocamlbuild = { - interface_only = []; - interface = [ "ocamlbuild_eliom" ]; - internal = [] - -} - -let ppx = { - interface_only = []; - interface = [ "ppx_eliom" ; "ppx_eliom_client" ; "ppx_eliom_type" ; "ppx_eliom_server" ]; - internal = [ "ppx_eliom_utils" ]; -} - - -let (-.-) name ext = name ^ "." ^ ext +type descr = + {interface_only : string list; interface : string list; internal : string list} + +let server = + { interface_only = + [ "eliom_content_sigs" + ; "eliom_form_sigs" + ; "eliom_parameter_sigs" + ; "eliom_registration_sigs" + ; "eliom_service_sigs" + ; "eliom_shared_sigs" ] + ; interface = + [ "eliom_bus" + ; "eliom_client_value" + ; "eliom_syntax" + ; "eliom_client" + ; "eliom_comet" + ; "eliom_common" + ; "eliom_config" + ; "eliom_content" + ; "eliom_extension" + ; "eliom_lib" + ; "eliom_mkreg" + ; "eliom_notif" + ; "eliom_parameter" + ; "eliom_react" + ; "eliom_shared" + ; "eliom_cscache" + ; "eliom_reference" + ; "eliom_registration" + ; "eliom_request_info" + ; "eliom_service" + ; "eliom_state" + ; "eliom_tools" + ; "eliom_types" + ; "eliom_uri" + ; "eliom_wrap" ] + ; internal = + [ "eliom_comet_base" + ; "eliom_common_base" + ; "eliom_runtime" + ; "eliom_content_" + ; "eliom_content_core" + ; "eliom_cookies_base" + ; "eliom_error_pages" + ; "eliom_form" + ; "eliom_lazy" + ; "eliom_lib_base" + ; "eliom_parameter_base" + ; "eliom_process" + ; "eliom_service_base" + ; "eliom_route" + ; "eliom_route_base" + ; "eliom_shared_content" + ; "eliom_types_base" + ; "eliom_client_main" + ; "eliommod" + ; "eliommod_cli" + ; "eliommod_cookies" + ; "eliommod_datasess" + ; "eliommod_gc" + ; "eliommod_pagegen" + ; "eliommod_parameters" + ; "eliommod_persess" + ; "eliommod_sersess" + ; "eliommod_sessadmin" + ; "eliommod_sessexpl" + ; "eliommod_sessiongroups" + ; "eliommod_timeouts" ] } + +let client = + { interface_only = + [ "eliom_content_sigs" + ; "eliom_form_sigs" + ; "eliom_parameter_sigs" + ; "eliom_registration_sigs" + ; "eliom_service_sigs" + ; "eliom_shared_sigs" ] + ; interface = + [ "eliom_bus" + ; "eliom_client_value" + ; "eliom_client_core" + ; "eliom_client" + ; "eliom_comet" + ; "eliom_config" + ; "eliom_content" + ; "eliom_content_core" + ; "eliom_lazy" + ; "eliom_lib" + ; "eliom_parameter" + ; "eliom_react" + ; "eliom_shared" + ; "eliom_cscache" + ; "eliom_registration" + ; "eliom_service" + ; "eliom_tools" + ; "eliom_types" + ; "eliom_unwrap" + ; "eliom_uri" ] + ; internal = + [ "eliom_comet_base" + ; "eliom_common" + ; "eliom_common_base" + ; "eliom_runtime" + ; "eliom_content_" + ; "eliom_cookies_base" + ; "eliom_form" + ; "eliom_lib_base" + ; "eliom_parameter_base" + ; "eliom_process" + ; "eliom_request" + ; "eliom_request_info" + ; "eliom_service_base" + ; "eliom_route" + ; "eliom_route_base" + ; "eliom_shared_content" + ; "eliom_types_base" + ; "eliommod_cookies" + ; "eliommod_dom" + ; "eliommod_parameters" ] } + +let server_ext = + { interface_only = [] + ; interface = ["atom_feed"; "eliom_atom"; "eliom_openid"; "eliom_s2s"] + ; internal = [] } + +let ocamlbuild = + {interface_only = []; interface = ["ocamlbuild_eliom"]; internal = []} + +let ppx = + { interface_only = [] + ; interface = + ["ppx_eliom"; "ppx_eliom_client"; "ppx_eliom_type"; "ppx_eliom_server"] + ; internal = ["ppx_eliom_utils"] } + +let ( -.- ) name ext = name ^ "." ^ ext + let exts el sl = - List.flatten ( - List.map (fun ext -> - List.map (fun name -> - name -.- ext) sl) el) + List.flatten (List.map (fun ext -> List.map (fun name -> name -.- ext) sl) el) let list_to_file filename list = let oc = open_out filename in - List.iter (fun s -> - output_string oc s; - output_char oc '\n'; - ) list; - close_out oc;; - -let client_mllib = - client.interface @ client.internal - -let client_extra = - exts ["cmi"] (client.interface_only @ client.interface) - -let client_api = - client.interface_only @ client.interface + List.iter (fun s -> output_string oc s; output_char oc '\n') list; + close_out oc -let server_mllib = - server.interface @ server.internal +let client_mllib = client.interface @ client.internal +let client_extra = exts ["cmi"] (client.interface_only @ client.interface) +let client_api = client.interface_only @ client.interface +let server_mllib = server.interface @ server.internal let server_extra = - exts ["cmi"] (server.interface_only @ server.interface) @ - exts ["cmx"] (server.interface @ server.internal) - -let server_api = - server.interface_only @ server.interface + exts ["cmi"] (server.interface_only @ server.interface) + @ exts ["cmx"] (server.interface @ server.internal) +let server_api = server.interface_only @ server.interface let server_ext_mllib = server_ext.interface @ server_ext.internal + let server_ext_extra = - exts ["cmi"] (server_ext.interface_only @ server_ext.interface) @ - exts ["cmx"] (server_ext.interface @ server_ext.internal) + exts ["cmi"] (server_ext.interface_only @ server_ext.interface) + @ exts ["cmx"] (server_ext.interface @ server_ext.internal) let ocamlbuild_mllib = ocamlbuild.interface @ ocamlbuild.internal + let ocamlbuild_extra = - exts ["cmi"] (ocamlbuild.interface_only @ ocamlbuild.interface) @ - exts ["cmx"] (ocamlbuild.interface @ ocamlbuild.internal) -let ocamlbuild_api = ocamlbuild.interface_only @ ocamlbuild.interface + exts ["cmi"] (ocamlbuild.interface_only @ ocamlbuild.interface) + @ exts ["cmx"] (ocamlbuild.interface @ ocamlbuild.internal) +let ocamlbuild_api = ocamlbuild.interface_only @ ocamlbuild.interface let ppx_mllib = ppx.interface @ ppx.internal -let ppx_extra = - exts ["cmi"] ppx.interface @ - exts ["cmx"] (ppx.interface @ ppx.internal) -let ppx_api = ppx.interface +let ppx_extra = + exts ["cmi"] ppx.interface @ exts ["cmx"] (ppx.interface @ ppx.internal) +let ppx_api = ppx.interface let templates_dir = "pkg/distillery" let templates = Array.to_list (Sys.readdir templates_dir) + let templates_files = - List.map (fun name -> - name, Array.to_list (Sys.readdir (templates_dir^"/"^name))) templates + List.map + (fun name -> name, Array.to_list (Sys.readdir (templates_dir ^ "/" ^ name))) + templates diff --git a/src/lib/client/eliommod_cookies.ml b/src/lib/client/eliommod_cookies.ml index 517ad81704..997b023ff9 100644 --- a/src/lib/client/eliommod_cookies.ml +++ b/src/lib/client/eliommod_cookies.ml @@ -19,100 +19,103 @@ open Js_of_ocaml open Eliom_lib - include Eliom_cookies_base (* CCC The tables are indexed by the hostname, not the port appear. there are no particular reason. If needed it is possible to add it *) let cookie_tables - : (float option * string * bool) Ocsigen_cookie_map.Map_inner.t - Ocsigen_cookie_map.Map_path.t Jstable.t - = Jstable.create () + : (float option * string * bool) Ocsigen_cookie_map.Map_inner.t + Ocsigen_cookie_map.Map_path.t + Jstable.t + = + Jstable.create () (** [in_local_storage] implements cookie substitutes for iOS WKWebView *) -let get_table ?(in_local_storage=false) = function +let get_table ?(in_local_storage = false) = function | None -> Ocsigen_cookie_map.Map_path.empty | Some host -> - if in_local_storage then - let host = Js.string (host ^ "/substitutes") in - Js.Optdef.case (Dom_html.window##.localStorage) - (fun () -> Ocsigen_cookie_map.Map_path.empty) - (fun st -> - Js.Opt.case (st##(getItem host)) - (fun () -> Ocsigen_cookie_map.Map_path.empty) - (fun v -> Json.unsafe_input v)) - else - Js.Optdef.get (Jstable.find cookie_tables (Js.string host)) - (fun () -> Ocsigen_cookie_map.Map_path.empty) + if in_local_storage + then + let host = Js.string (host ^ "/substitutes") in + Js.Optdef.case + Dom_html.window##.localStorage + (fun () -> Ocsigen_cookie_map.Map_path.empty) + (fun st -> + Js.Opt.case + st ## (getItem host) + (fun () -> Ocsigen_cookie_map.Map_path.empty) + (fun v -> Json.unsafe_input v)) + else + Js.Optdef.get + (Jstable.find cookie_tables (Js.string host)) + (fun () -> Ocsigen_cookie_map.Map_path.empty) (** [in_local_storage] implements cookie substitutes for iOS WKWebView *) -let set_table ?(in_local_storage=false) host t = +let set_table ?(in_local_storage = false) host t = match host with - | None -> () - | Some host -> - if in_local_storage then + | None -> () + | Some host -> + if in_local_storage + then let host = Js.string (host ^ "/substitutes") in - Js.Optdef.case (Dom_html.window##.localStorage) + Js.Optdef.case + Dom_html.window##.localStorage (fun () -> ()) - (fun st -> st##(setItem host ((Json.output t)))) - else - Jstable.add cookie_tables (Js.string host) t + (fun st -> st ## (setItem host (Json.output t))) + else Jstable.add cookie_tables (Js.string host) t let now () = let date = new%js Js.date_now in - Js.to_float (date##getTime) /. 1000. + Js.to_float date##getTime /. 1000. (** [in_local_storage] implements cookie substitutes for iOS WKWebView *) -let update_cookie_table ?(in_local_storage=false) host cookies = +let update_cookie_table ?(in_local_storage = false) host cookies = let now = now () in Ocsigen_cookie_map.Map_path.iter (fun path table -> - Ocsigen_cookie_map.Map_inner.iter - (fun name -> function - | OSet (Some exp, _, _) when exp <= now -> + Ocsigen_cookie_map.Map_inner.iter + (fun name -> function + | OSet (Some exp, _, _) when exp <= now -> set_table ~in_local_storage host (Ocsigen_cookie_map.Poly.remove ~path name (get_table ~in_local_storage host)) - | OUnset -> + | OUnset -> set_table ~in_local_storage host (Ocsigen_cookie_map.Poly.remove ~path name (get_table ~in_local_storage host)) - | OSet (exp, value, secure) -> + | OSet (exp, value, secure) -> set_table ~in_local_storage host - (Ocsigen_cookie_map.Poly.add ~path name - (exp, value, secure) + (Ocsigen_cookie_map.Poly.add ~path name (exp, value, secure) (get_table ~in_local_storage host))) - table) + table) cookies (** [in_local_storage] implements cookie substitutes for iOS WKWebView *) -let get_cookies_to_send ?(in_local_storage=false) host https path = +let get_cookies_to_send ?(in_local_storage = false) host https path = let now = now () in Ocsigen_cookie_map.Map_path.fold (fun cpath t cookies_to_send -> if Url.is_prefix_skip_end_slash - (Url.remove_slash_at_beginning cpath) - (Url.remove_slash_at_beginning path) + (Url.remove_slash_at_beginning cpath) + (Url.remove_slash_at_beginning path) then Ocsigen_cookie_map.Map_inner.fold (fun name (exp, value, secure) cookies_to_send -> - match exp with - | Some exp when exp <= now -> - set_table ~in_local_storage host - (Ocsigen_cookie_map.Poly.remove cpath - name (get_table ~in_local_storage host)); - cookies_to_send - | _ -> - if (not secure) || https - then (name,value)::cookies_to_send - else cookies_to_send) + match exp with + | Some exp when exp <= now -> + set_table ~in_local_storage host + (Ocsigen_cookie_map.Poly.remove cpath name + (get_table ~in_local_storage host)); + cookies_to_send + | _ -> + if (not secure) || https + then (name, value) :: cookies_to_send + else cookies_to_send) t cookies_to_send - else - cookies_to_send) + else cookies_to_send) (get_table ~in_local_storage host) [] - let make_new_session_id () = - failwith "Cannot define anonymous coservices on client side. \ - Ask their values to the server." + failwith + "Cannot define anonymous coservices on client side. Ask their values to the server." diff --git a/src/lib/client/eliommod_dom.ml b/src/lib/client/eliommod_dom.ml index 05be95c61f..455a0afcce 100644 --- a/src/lib/client/eliommod_dom.ml +++ b/src/lib/client/eliommod_dom.ml @@ -29,7 +29,8 @@ let iter_nodeList nodeList f = done let iter_attrList (attrList : Dom.attr Dom.namedNodeMap Js.t) - (f : Dom.attr Js.t -> unit) = + (f : Dom.attr Js.t -> unit) + = for i = 0 to attrList##.length - 1 do (* Unsafe.get is ten time faster than nodeList##item. Is it the same for attrList ? *) @@ -40,230 +41,229 @@ let iter_attrList (attrList : Dom.attr Dom.namedNodeMap Js.t) Js.Opt.iter v f done - (* Dummy type used in the following "test_*" functions to test the presence of methods in various browsers. *) -class type dom_tester = object - method compareDocumentPosition : unit Js.optdef Js.prop - method querySelectorAll : unit Js.optdef Js.prop - method classList : unit Js.optdef Js.prop - method createEvent : unit Js.optdef Js.prop - method onpageshow : unit Js.optdef Js.prop - method onpagehide : unit Js.optdef Js.prop - method onhashchange : unit Js.optdef Js.prop -end +class type dom_tester = + object + method compareDocumentPosition : unit Js.optdef Js.prop + method querySelectorAll : unit Js.optdef Js.prop + method classList : unit Js.optdef Js.prop + method createEvent : unit Js.optdef Js.prop + method onpageshow : unit Js.optdef Js.prop + method onpagehide : unit Js.optdef Js.prop + method onhashchange : unit Js.optdef Js.prop + end let test_querySelectorAll () = Js.Optdef.test - ((Js.Unsafe.coerce Dom_html.document:dom_tester Js.t)##.querySelectorAll) + (Js.Unsafe.coerce Dom_html.document : dom_tester Js.t)##.querySelectorAll let test_compareDocumentPosition () = Js.Optdef.test - ((Js.Unsafe.coerce - Dom_html.document:dom_tester Js.t)##.compareDocumentPosition) + (Js.Unsafe.coerce Dom_html.document : dom_tester Js.t)##.compareDocumentPosition let test_classList () = Js.Optdef.test - ((Js.Unsafe.coerce - Dom_html.document##.documentElement:dom_tester Js.t)##.classList) + (Js.Unsafe.coerce Dom_html.document##.documentElement : dom_tester Js.t)##.classList let test_createEvent () = Js.Optdef.test - ((Js.Unsafe.coerce Dom_html.document:dom_tester Js.t)##.createEvent) + (Js.Unsafe.coerce Dom_html.document : dom_tester Js.t)##.createEvent let test_pageshow_pagehide () = - let tester = (Js.Unsafe.coerce Dom_html.window:dom_tester Js.t) in - Js.Optdef.test tester##.onpageshow - && Js.Optdef.test tester##.onpagehide + let tester = (Js.Unsafe.coerce Dom_html.window : dom_tester Js.t) in + Js.Optdef.test tester##.onpageshow && Js.Optdef.test tester##.onpagehide let test_onhashchange () = Js.Optdef.test - ((Js.Unsafe.coerce Dom_html.window:dom_tester Js.t)##.onhashchange) + (Js.Unsafe.coerce Dom_html.window : dom_tester Js.t)##.onhashchange -let fast_ancessor (elt1:#Dom.node Js.t) (elt2:#Dom.node Js.t) = +let fast_ancessor (elt1 : #Dom.node Js.t) (elt2 : #Dom.node Js.t) = let open Dom.DocumentPosition in - has (elt1##(compareDocumentPosition ((elt2:>Dom.node Js.t)))) contained_by + has elt1 ## (compareDocumentPosition (elt2 :> Dom.node Js.t)) contained_by -let slow_ancessor (elt1:#Dom.node Js.t) (elt2:#Dom.node Js.t) = +let slow_ancessor (elt1 : #Dom.node Js.t) (elt2 : #Dom.node Js.t) = let rec check_parent n = - if n == (elt1:>Dom.node Js.t) + if n == (elt1 :> Dom.node Js.t) then true else match Js.Opt.to_option n##.parentNode with | None -> false | Some p -> check_parent p in - check_parent (elt2:>Dom.node Js.t) + check_parent (elt2 :> Dom.node Js.t) let ancessor = - if test_compareDocumentPosition () - then fast_ancessor - else slow_ancessor + if test_compareDocumentPosition () then fast_ancessor else slow_ancessor let fast_select_request_nodes root = - root##(querySelectorAll (Js.string - ("."^Eliom_runtime.RawXML.request_node_class))) + root + ## (querySelectorAll + (Js.string ("." ^ Eliom_runtime.RawXML.request_node_class))) let fast_select_nodes root = if !Eliom_config.debug_timings - then Firebug.console##(time (Js.string "fast_select_nodes")); + then Firebug.console ## (time (Js.string "fast_select_nodes")); let a_nodeList : Dom_html.element Dom.nodeList Js.t = - root##(querySelectorAll - (Js.string ("a."^Eliom_runtime.RawXML.ce_call_service_class))) + root + ## (querySelectorAll + (Js.string ("a." ^ Eliom_runtime.RawXML.ce_call_service_class))) in let a_nodeList : Dom_html.anchorElement Dom.nodeList Js.t = Js.Unsafe.coerce a_nodeList in let form_nodeList : Dom_html.element Dom.nodeList Js.t = - root##(querySelectorAll - (Js.string ("form."^Eliom_runtime.RawXML.ce_call_service_class))) + root + ## (querySelectorAll + (Js.string ("form." ^ Eliom_runtime.RawXML.ce_call_service_class))) in let form_nodeList : Dom_html.formElement Dom.nodeList Js.t = Js.Unsafe.coerce form_nodeList in let process_node_nodeList = - root##(querySelectorAll - (Js.string ("."^Eliom_runtime.RawXML.process_node_class))) + root + ## (querySelectorAll + (Js.string ("." ^ Eliom_runtime.RawXML.process_node_class))) in let closure_nodeList = - root##(querySelectorAll - (Js.string ("."^Eliom_runtime.RawXML.ce_registered_closure_class))) + root + ## (querySelectorAll + (Js.string ("." ^ Eliom_runtime.RawXML.ce_registered_closure_class))) in let attrib_nodeList = - root##(querySelectorAll - (Js.string ("."^Eliom_runtime.RawXML.ce_registered_attr_class))) + root + ## (querySelectorAll + (Js.string ("." ^ Eliom_runtime.RawXML.ce_registered_attr_class))) in if !Eliom_config.debug_timings - then Firebug.console##(timeEnd (Js.string "fast_select_nodes")); - a_nodeList, form_nodeList, process_node_nodeList, - closure_nodeList, attrib_nodeList - -let slow_has_classes (node:Dom_html.element Js.t) = + then Firebug.console ## (timeEnd (Js.string "fast_select_nodes")); + ( a_nodeList + , form_nodeList + , process_node_nodeList + , closure_nodeList + , attrib_nodeList ) + +let slow_has_classes (node : Dom_html.element Js.t) = let classes = (* IE<9: className is not set after change_page; getAttribute("class") does not work for the initial document *) let str = if node##.className = Js.string "" - then Js.Opt.get (node##(getAttribute (Js.string "class"))) + then + Js.Opt.get + node ## (getAttribute (Js.string "class")) (fun () -> Js.string "") else node##.className in - Js.str_array str##(split (Js.string " ")) + Js.str_array str ## (split (Js.string " ")) in let found_call_service = ref false in let found_process_node = ref false in let found_closure = ref false in let found_attrib = ref false in - for i = 0 to (classes##.length) - 1 do + for i = 0 to classes##.length - 1 do found_call_service := - (Js.array_get classes i - == Js.def (Js.string Eliom_runtime.RawXML.ce_call_service_class)) + Js.array_get classes i + == Js.def (Js.string Eliom_runtime.RawXML.ce_call_service_class) || !found_call_service; found_process_node := - (Js.array_get classes i - == Js.def (Js.string Eliom_runtime.RawXML.process_node_class)) + Js.array_get classes i + == Js.def (Js.string Eliom_runtime.RawXML.process_node_class) || !found_process_node; found_closure := - (Js.array_get classes i - == Js.def (Js.string Eliom_runtime.RawXML.ce_registered_closure_class)) + Js.array_get classes i + == Js.def (Js.string Eliom_runtime.RawXML.ce_registered_closure_class) || !found_closure; found_attrib := - (Js.array_get classes i - == Js.def (Js.string Eliom_runtime.RawXML.ce_registered_attr_class)) - || !found_attrib; + Js.array_get classes i + == Js.def (Js.string Eliom_runtime.RawXML.ce_registered_attr_class) + || !found_attrib done; - !found_call_service,!found_process_node,!found_closure,!found_attrib + !found_call_service, !found_process_node, !found_closure, !found_attrib -let slow_has_request_class (node:Dom_html.element Js.t) = - let classes = Js.str_array (node##.className##(split (Js.string " "))) in +let slow_has_request_class (node : Dom_html.element Js.t) = + let classes = Js.str_array node ##. className ## (split (Js.string " ")) in let found_request_node = ref false in - for i = 0 to (classes##.length) - 1 do + for i = 0 to classes##.length - 1 do found_request_node := - (Js.array_get classes i - == Js.def (Js.string Eliom_runtime.RawXML.request_node_class)) - || !found_request_node; + Js.array_get classes i + == Js.def (Js.string Eliom_runtime.RawXML.request_node_class) + || !found_request_node done; !found_request_node -let fast_has_classes (node:Dom_html.element Js.t) = - Js.to_bool (node##.classList##(contains - ((Js.string Eliom_runtime.RawXML.ce_call_service_class)))), - Js.to_bool (node##.classList##(contains - ((Js.string Eliom_runtime.RawXML.process_node_class)))), - Js.to_bool (node##.classList##(contains - ((Js.string Eliom_runtime.RawXML.ce_registered_closure_class)))), - Js.to_bool (node##.classList##(contains - ((Js.string Eliom_runtime.RawXML.ce_registered_attr_class)))) - -let fast_has_request_class (node:Dom_html.element Js.t) = - Js.to_bool (node##.classList##(contains - ((Js.string Eliom_runtime.RawXML.request_node_class)))) - -let has_classes : Dom_html.element Js.t -> (bool*bool*bool*bool) = - if test_classList () - then fast_has_classes - else slow_has_classes +let fast_has_classes (node : Dom_html.element Js.t) = + ( Js.to_bool + node ##. classList + ## (contains (Js.string Eliom_runtime.RawXML.ce_call_service_class)) + , Js.to_bool + node ##. classList + ## (contains (Js.string Eliom_runtime.RawXML.process_node_class)) + , Js.to_bool + node ##. classList + ## (contains (Js.string Eliom_runtime.RawXML.ce_registered_closure_class)) + , Js.to_bool + node ##. classList + ## (contains (Js.string Eliom_runtime.RawXML.ce_registered_attr_class)) ) + +let fast_has_request_class (node : Dom_html.element Js.t) = + Js.to_bool + node ##. classList + ## (contains (Js.string Eliom_runtime.RawXML.request_node_class)) + +let has_classes : Dom_html.element Js.t -> bool * bool * bool * bool = + if test_classList () then fast_has_classes else slow_has_classes let has_request_class : Dom_html.element Js.t -> bool = - if test_classList () - then fast_has_request_class - else slow_has_request_class + if test_classList () then fast_has_request_class else slow_has_request_class -let slow_select_request_nodes (root:Dom_html.element Js.t) = +let slow_select_request_nodes (root : Dom_html.element Js.t) = let node_array = new%js Js.array_empty in - let rec traverse (node:Dom.node Js.t) = + let rec traverse (node : Dom.node Js.t) = match node##.nodeType with | Dom.ELEMENT -> - let node = (Js.Unsafe.coerce node:Dom_html.element Js.t) in - if has_request_class node - then ignore (node_array##(push node)); - iter_nodeList node##.childNodes traverse + let node = (Js.Unsafe.coerce node : Dom_html.element Js.t) in + if has_request_class node then ignore node_array ## (push node); + iter_nodeList node##.childNodes traverse | _ -> () in - traverse (root:>Dom.node Js.t); - (Js.Unsafe.coerce node_array:Dom_html.element Dom.nodeList Js.t) + traverse (root :> Dom.node Js.t); + (Js.Unsafe.coerce node_array : Dom_html.element Dom.nodeList Js.t) -let slow_select_nodes (root:Dom_html.element Js.t) = +let slow_select_nodes (root : Dom_html.element Js.t) = let a_array = new%js Js.array_empty in let form_array = new%js Js.array_empty in let node_array = new%js Js.array_empty in let closure_array = new%js Js.array_empty in - let attrib_array = new%js Js.array_empty in - let rec traverse (node:Dom.node Js.t) = + let attrib_array = new%js Js.array_empty in + let rec traverse (node : Dom.node Js.t) = match node##.nodeType with | Dom.ELEMENT -> - let node = (Js.Unsafe.coerce node:Dom_html.element Js.t) in - let call_service,process_node,closure,attrib = has_classes node in - begin - if call_service + let node = (Js.Unsafe.coerce node : Dom_html.element Js.t) in + let call_service, process_node, closure, attrib = has_classes node in + (if call_service then match Dom_html.tagged node with - | Dom_html.A e -> ignore (a_array##(push e)) - | Dom_html.Form e -> ignore (form_array##(push e)) - | _ -> Lwt_log.raise_error_f ~section - "%s element tagged as eliom link" - (Js.to_string (node##.tagName)) - end; - if process_node - then ignore (node_array##(push node)); - if closure - then ignore (closure_array##(push node)); - if attrib - then ignore (attrib_array##(push node)); - iter_nodeList node##.childNodes traverse + | Dom_html.A e -> ignore a_array ## (push e) + | Dom_html.Form e -> ignore form_array ## (push e) + | _ -> + Lwt_log.raise_error_f ~section "%s element tagged as eliom link" + (Js.to_string node##.tagName)); + if process_node then ignore node_array ## (push node); + if closure then ignore closure_array ## (push node); + if attrib then ignore attrib_array ## (push node); + iter_nodeList node##.childNodes traverse | _ -> () in - traverse (root:>Dom.node Js.t); - (Js.Unsafe.coerce a_array:Dom_html.anchorElement Dom.nodeList Js.t), - (Js.Unsafe.coerce form_array:Dom_html.formElement Dom.nodeList Js.t), - (Js.Unsafe.coerce node_array:Dom_html.element Dom.nodeList Js.t), - (Js.Unsafe.coerce closure_array:Dom_html.element Dom.nodeList Js.t), - (Js.Unsafe.coerce attrib_array:Dom_html.element Dom.nodeList Js.t) + traverse (root :> Dom.node Js.t); + ( (Js.Unsafe.coerce a_array : Dom_html.anchorElement Dom.nodeList Js.t) + , (Js.Unsafe.coerce form_array : Dom_html.formElement Dom.nodeList Js.t) + , (Js.Unsafe.coerce node_array : Dom_html.element Dom.nodeList Js.t) + , (Js.Unsafe.coerce closure_array : Dom_html.element Dom.nodeList Js.t) + , (Js.Unsafe.coerce attrib_array : Dom_html.element Dom.nodeList Js.t) ) let select_nodes = - if test_querySelectorAll () - then fast_select_nodes - else slow_select_nodes + if test_querySelectorAll () then fast_select_nodes else slow_select_nodes let select_request_nodes = if test_querySelectorAll () @@ -274,57 +274,59 @@ let select_request_nodes = let createEvent_ie ev_type = let evt : #Dom_html.event Js.t = - ((Js.Unsafe.coerce Dom_html.document))##createEventObject + (Js.Unsafe.coerce Dom_html.document)##createEventObject in - (Js.Unsafe.coerce evt)##._type := ((Js.string "on")##(concat ev_type)); + (Js.Unsafe.coerce evt)##._type := (Js.string "on") ## (concat ev_type); evt let createEvent_normal ev_type = let evt : #Dom_html.event Js.t = - (Js.Unsafe.coerce Dom_html.document)##(createEvent (Js.string "HTMLEvents")) + (Js.Unsafe.coerce Dom_html.document) + ## (createEvent (Js.string "HTMLEvents")) in - let () = (Js.Unsafe.coerce evt)##(initEvent ev_type false false) in + let () = (Js.Unsafe.coerce evt) ## (initEvent ev_type false false) in evt let createEvent = - if test_createEvent () - then createEvent_normal - else createEvent_ie - + if test_createEvent () then createEvent_normal else createEvent_ie (* DOM traversal *) -class type ['element] get_tag = object - method getElementsByTagName - : Js.js_string Js.t -> 'element Dom.nodeList Js.t Js.meth -end +class type ['element] get_tag = + object + method getElementsByTagName : + Js.js_string Js.t -> 'element Dom.nodeList Js.t Js.meth + end (* We can't use Dom_html.document##head: it is not defined in ff3.6... *) -let get_head (page:'element #get_tag Js.t) : 'element Js.t = +let get_head (page : 'element #get_tag Js.t) : 'element Js.t = Js.Opt.get - ((page##(getElementsByTagName (Js.string "head")))##(item (0))) + page ## (getElementsByTagName (Js.string "head")) ## (item 0) (fun () -> Lwt_log.raise_error ~section "get_head") -let get_body (page:'element #get_tag Js.t) : 'element Js.t = +let get_body (page : 'element #get_tag Js.t) : 'element Js.t = Js.Opt.get - ((page##(getElementsByTagName (Js.string "body")))##(item (0))) + page ## (getElementsByTagName (Js.string "body")) ## (item 0) (fun () -> Lwt_log.raise_error ~section "get_body") -let iter_dom_array (f:'a -> unit) - (a: Js.gen_prop; - item : int -> 'a Js.opt Js.meth; ..> Js.t) = +let iter_dom_array (f : 'a -> unit) + (a : + < length : < get : int ; .. > Js.gen_prop + ; item : int -> 'a Js.opt Js.meth + ; .. > + Js.t) + = let length = a##.length in for i = 0 to length - 1 do - Js.Opt.iter (a##(item i)) f; + Js.Opt.iter a ## (item i) f done -let copy_text t = Dom_html.document##(createTextNode t##.data) +let copy_text t = Dom_html.document ## (createTextNode t##.data) (* ie, ff3.6 and safari does not like setting innerHTML on html and head nodes: we need to rebuild the HTML dom tree from the XML dom tree received in the xhr *) - (* BEGIN IE<9 HACK: appendChild is broken in ie: see @@ -334,99 +336,104 @@ let copy_text t = Dom_html.document##(createTextNode t##.data) This fix appending to script element. TODO: it is also broken when appending tr to tbody, need to find a solution *) -let add_childrens (elt:Dom_html.element Js.t) (sons:Dom.node Js.t list) = +let add_childrens (elt : Dom_html.element Js.t) (sons : Dom.node Js.t list) = try List.iter (Dom.appendChild elt) sons - with - | exn -> + with exn -> ( (* this code is ie only, there are no reason for an appendChild to fail normally *) let concat l = let rec concat acc = function | [] -> acc - | t::q -> - let txt = - match (Dom.nodeType t) with - | Dom.Text t -> t - | _ -> Lwt_log.raise_error_f ~section - "add_childrens: not text node in tag %s" - (Js.to_string (elt##.tagName)) - in - concat (acc##(concat txt##.data)) q + | t :: q -> + let txt = + match Dom.nodeType t with + | Dom.Text t -> t + | _ -> + Lwt_log.raise_error_f ~section + "add_childrens: not text node in tag %s" + (Js.to_string elt##.tagName) + in + concat acc ## (concat txt##.data) q in concat (Js.string "") l in match Dom_html.tagged elt with - | Dom_html.Script elt -> - elt##.text := concat sons + | Dom_html.Script elt -> elt##.text := concat sons | Dom_html.Style elt -> - (* we need to append the style node to something. If we + (* we need to append the style node to something. If we don't do that the styleSheet field is not created if we. And we can't do it by creating it with the ie specific document.createStyleSheet: the styleSheet field is not initialised and it can't be set either. *) - let d = Dom_html.createHead Dom_html.document in - Dom.appendChild d elt; - (Js.Unsafe.coerce elt)##.styleSheet##.cssText := concat sons - | _ -> Lwt_log.raise_error ~section ~exn "add_childrens: can't appendChild" + let d = Dom_html.createHead Dom_html.document in + Dom.appendChild d elt; + (Js.Unsafe.coerce elt)##.styleSheet##.cssText := concat sons + | _ -> Lwt_log.raise_error ~section ~exn "add_childrens: can't appendChild") (* END IE HACK *) -let copy_element (e:Dom.element Js.t) - (registered_process_node:(Js.js_string Js.t -> bool)) - : Dom_html.element Js.t = - let rec aux (e:Dom.element Js.t) = - let copy = Dom_html.document##(createElement e##.tagName) in +let copy_element (e : Dom.element Js.t) + (registered_process_node : Js.js_string Js.t -> bool) + : Dom_html.element Js.t + = + let rec aux (e : Dom.element Js.t) = + let copy = Dom_html.document ## (createElement e##.tagName) in (* IE<9: Copy className separately, it's not updated when displayed *) - Js.Opt.iter (Dom_html.CoerceTo.element e) - (fun e -> copy##.className := e##.className); - let node_id = Js.Opt.to_option - (e##(getAttribute (Js.string Eliom_runtime.RawXML.node_id_attrib))) in + Js.Opt.iter (Dom_html.CoerceTo.element e) (fun e -> + copy##.className := e##.className); + let node_id = + Js.Opt.to_option + e ## (getAttribute (Js.string Eliom_runtime.RawXML.node_id_attrib)) + in match node_id with | Some id when registered_process_node id -> - Js.Opt.iter - (e##(getAttribute (Js.string "class"))) - (fun classes -> copy##(setAttribute (Js.string "class") classes)); - copy##(setAttribute (Js.string Eliom_runtime.RawXML.node_id_attrib) id); - Some copy + Js.Opt.iter + e ## (getAttribute (Js.string "class")) + (fun classes -> copy ## (setAttribute (Js.string "class") classes)); + copy + ## (setAttribute (Js.string Eliom_runtime.RawXML.node_id_attrib) id); + Some copy | _ -> - let add_attribute a = - Js.Opt.iter (Dom.CoerceTo.attr a) - (* we don't use copy##attributes##setNameditem: + let add_attribute a = + Js.Opt.iter (Dom.CoerceTo.attr a) + (* we don't use copy##attributes##setNameditem: in ie 9 it fail setting types of buttons... *) - (fun a -> copy##(setAttribute a##.name a##.value)) in - iter_dom_array add_attribute (e##.attributes); - let child_copies = List.map_filter - (fun child -> - match Dom.nodeType child with - | Dom.Text t -> Some (copy_text t:>Dom.node Js.t) - | Dom.Element child -> (aux child:>Dom.node Js.t option) - | _ -> None) - (Dom.list_of_nodeList (e##.childNodes)) in - add_childrens copy child_copies; - Some copy + (fun a -> copy ## (setAttribute a##.name a##.value)) + in + iter_dom_array add_attribute e##.attributes; + let child_copies = + List.map_filter + (fun child -> + match Dom.nodeType child with + | Dom.Text t -> Some (copy_text t :> Dom.node Js.t) + | Dom.Element child -> (aux child :> Dom.node Js.t option) + | _ -> None) + (Dom.list_of_nodeList e##.childNodes) + in + add_childrens copy child_copies; + Some copy in match aux e with | None -> Lwt_log.raise_error ~section "copy_element" | Some e -> e let html_document (src : Dom.element Dom.document Js.t) registered_process_node - : Dom_html.element Js.t = + : Dom_html.element Js.t + = let content = src##.documentElement in match Js.Opt.to_option (Dom_html.CoerceTo.element content) with - | Some e -> - begin - try Dom_html.document##(adoptNode ((e:>Dom.element Js.t))) with - | exn -> - Lwt_log.ign_debug ~section ~exn "can't adopt node, import instead"; - try Dom_html.document##(importNode ((e:>Dom.element Js.t)) (Js._true)) with - | exn -> - Lwt_log.ign_debug ~section ~exn "can't import node, copy instead"; - copy_element content registered_process_node - end + | Some e -> ( + try Dom_html.document ## (adoptNode (e :> Dom.element Js.t)) + with exn -> ( + Lwt_log.ign_debug ~section ~exn "can't adopt node, import instead"; + try Dom_html.document ## (importNode (e :> Dom.element Js.t) Js._true) + with exn -> + Lwt_log.ign_debug ~section ~exn "can't import node, copy instead"; + copy_element content registered_process_node)) | None -> - Lwt_log.ign_debug ~section - "can't adopt node, document not parsed as html. copy instead"; - copy_element content registered_process_node + Lwt_log.ign_debug ~section + "can't adopt node, document not parsed as html. copy instead"; + copy_element content registered_process_node (** CSS preloading. *) @@ -434,28 +441,28 @@ let spaces_re = Regexp.regexp " +" let is_stylesheet e = (* FIX: should eventually use Dom_html.element *) - Js.Opt.case (Dom_html.CoerceTo.link (Js.Unsafe.coerce e)) + Js.Opt.case + (Dom_html.CoerceTo.link (Js.Unsafe.coerce e)) (fun _ -> false) (fun e -> - List.exists (fun s -> s = "stylesheet") - (Regexp.split spaces_re (Js.to_string e##.rel)) - && - e##._type == Js.string "text/css") + List.exists + (fun s -> s = "stylesheet") + (Regexp.split spaces_re (Js.to_string e##.rel)) + && e##._type == Js.string "text/css") let basedir_re = Regexp.regexp "^(([^/?]*/)*)([^/?]*)(\\?.*)?$" + let basedir path = match Regexp.string_match basedir_re path 0 with | None -> "/" - | Some res -> + | Some res -> ( match Regexp.matched_group res 1 with - | None -> - (match Regexp.matched_group res 3 with - | Some ".." -> "../" - | _ -> "/") - | Some dir -> - (match Regexp.matched_group res 3 with - | Some ".." -> dir^"../" - | _ -> dir) + | None -> ( + match Regexp.matched_group res 3 with Some ".." -> "../" | _ -> "/") + | Some dir -> ( + match Regexp.matched_group res 3 with + | Some ".." -> dir ^ "../" + | _ -> dir)) let fetch_linked_css e = let rec extract acc (e : Dom.node Js.t) = @@ -463,102 +470,110 @@ let fetch_linked_css e = | Dom.Element e when is_stylesheet e -> let e : Dom_html.linkElement Js.t = Js.Unsafe.coerce e in let href = e##.href in - if Js.to_bool e##.disabled || e##.title##.length > 0 || href##.length = 0 + if Js.to_bool e##.disabled + || e##.title##.length > 0 + || href##.length = 0 then acc else let href = Js.to_string href in let css = - Eliom_request.http_get href [] Eliom_request.string_result in + Eliom_request.http_get href [] Eliom_request.string_result + in acc @ [e, (e##.media, href, css >|= snd)] | Dom.Element e -> - let c = e##.childNodes in - let acc = ref acc in - for i = 0 to c##.length - 1 do - acc := extract !acc (Js.Opt.get c##(item i) (fun _ -> assert false)) - done; - !acc - | _ -> acc in + let c = e##.childNodes in + let acc = ref acc in + for i = 0 to c##.length - 1 do + acc := extract !acc (Js.Opt.get c ## (item i) (fun _ -> assert false)) + done; + !acc + | _ -> acc + in extract [] (e :> Dom.node Js.t) -let url_content_raw = "([^'\\\"]([^\\\\\\)]|\\\\.)*)" +let url_content_raw = "([^'\\\"]([^\\\\\\)]|\\\\.)*)" let dbl_quoted_url_raw = "\"(([^\\\\\"]|\\\\.)*)\"" -let quoted_url_raw = "'(([^\\\\']|\\\\.)*)'" +let quoted_url_raw = "'(([^\\\\']|\\\\.)*)'" + let url_re = - Regexp.regexp (Printf.sprintf "url\\s*\\(\\s*(%s|%s|%s)\\s*\\)\\s*" - dbl_quoted_url_raw - quoted_url_raw - url_content_raw) + Regexp.regexp + (Printf.sprintf "url\\s*\\(\\s*(%s|%s|%s)\\s*\\)\\s*" dbl_quoted_url_raw + quoted_url_raw url_content_raw) + let raw_url_re = - Regexp.regexp (Printf.sprintf "\\s*(%s|%s)\\s*" - dbl_quoted_url_raw - quoted_url_raw) + Regexp.regexp + (Printf.sprintf "\\s*(%s|%s)\\s*" dbl_quoted_url_raw quoted_url_raw) let absolute_re = Regexp.regexp "\\s*(https?:\\/\\/|data:|file:|\\/)" -let absolute_re2 = Regexp.regexp "['\\\"]\\s*((https?:\\/\\/|data:|file:|\\/).*)['\\\"]$" + +let absolute_re2 = + Regexp.regexp "['\\\"]\\s*((https?:\\/\\/|data:|file:|\\/).*)['\\\"]$" exception Incorrect_url let parse_absolute ~prefix href = match Regexp.search absolute_re href 0 with - | Some (i, _) when i=0 -> (* absolute URL -> do not rewrite *) href - | _ -> + | Some (i, _) when i = 0 -> (* absolute URL -> do not rewrite *) href + | _ -> ( match Regexp.search absolute_re2 href 0 with - | Some (i, res) when i = 0 -> - (match Regexp.matched_group res 1 with - | Some href -> (* absolute URL -> do not rewrite *) href - | None -> raise Incorrect_url) - | _ -> prefix ^ href + | Some (i, res) when i = 0 -> ( + match Regexp.matched_group res 1 with + | Some href -> (* absolute URL -> do not rewrite *) href + | None -> raise Incorrect_url) + | _ -> prefix ^ href) let parse_url ~prefix css pos = match Regexp.search url_re css pos with - | Some (i, res) when i = pos -> - (i + String.length (Regexp.matched_string res), - match Regexp.matched_group res 2 with - | Some href -> parse_absolute ~prefix href - | None -> (match Regexp.matched_group res 3 with - | Some href -> parse_absolute ~prefix href - | None -> (match Regexp.matched_group res 4 with - | Some href -> parse_absolute ~prefix href - | None -> raise Incorrect_url ))) - | _ -> - match Regexp.search raw_url_re css pos with - | Some (i, res) when i = pos -> - ( i + String.length (Regexp.matched_string res), - match Regexp.matched_group res 1 with + | Some (i, res) when i = pos -> ( + ( i + String.length (Regexp.matched_string res) + , match Regexp.matched_group res 2 with | Some href -> parse_absolute ~prefix href - | None -> raise Incorrect_url ) - | _ -> raise Incorrect_url + | None -> ( + match Regexp.matched_group res 3 with + | Some href -> parse_absolute ~prefix href + | None -> ( + match Regexp.matched_group res 4 with + | Some href -> parse_absolute ~prefix href + | None -> raise Incorrect_url)) )) + | _ -> ( + match Regexp.search raw_url_re css pos with + | Some (i, res) when i = pos -> ( + ( i + String.length (Regexp.matched_string res) + , match Regexp.matched_group res 1 with + | Some href -> parse_absolute ~prefix href + | None -> raise Incorrect_url )) + | _ -> raise Incorrect_url) let parse_media css pos = let i = - try String.index_from css pos ';' - with Not_found -> String.length css + try String.index_from css pos ';' with Not_found -> String.length css in - (i+1, String.sub css pos (i - pos)) + i + 1, String.sub css pos (i - pos) (* Look for relative URL only... *) -let url_re = Regexp.regexp "url\\s*\\(\\s*(?!('|\")?(https?:\\/\\/|data:|file:|\\/))" +let url_re = + Regexp.regexp "url\\s*\\(\\s*(?!('|\")?(https?:\\/\\/|data:|file:|\\/))" let rewrite_css_url ~prefix css pos = let len = String.length css - pos in - let buf = Buffer.create (len + len / 2) in + let buf = Buffer.create (len + (len / 2)) in let rec rewrite pos = - if pos < String.length css then + if pos < String.length css + then match Regexp.search url_re css pos with | None -> Buffer.add_substring buf css pos (String.length css - pos) - | Some (i, _res) -> - Buffer.add_substring buf css pos (i - pos); - try - let i, href = parse_url ~prefix css i in - Buffer.add_string buf "url('"; - Buffer.add_string buf href; - Buffer.add_string buf "')"; - rewrite i - with Incorrect_url -> - Buffer.add_substring buf css i (String.length css - i) + | Some (i, _res) -> ( + Buffer.add_substring buf css pos (i - pos); + try + let i, href = parse_url ~prefix css i in + Buffer.add_string buf "url('"; + Buffer.add_string buf href; + Buffer.add_string buf "')"; + rewrite i + with Incorrect_url -> + Buffer.add_substring buf css i (String.length css - i)) in - rewrite pos; - Buffer.contents buf + rewrite pos; Buffer.contents buf let import_re = Regexp.regexp "@import\\s*" @@ -567,56 +582,58 @@ let rec rewrite_css ~max (media, href, css) = css >>= function | None -> Lwt.return_nil | Some css -> - if !Eliom_config.debug_timings then - Firebug.console##(time (Js.string ("rewrite_CSS: "^href))); - let%lwt imports, css = - rewrite_css_import ~max ~prefix:(basedir href) ~media css 0 - in - if !Eliom_config.debug_timings then - Firebug.console##(timeEnd (Js.string ("rewrite_CSS: "^href))); - Lwt.return (imports @ [(media, css)]) - with _ -> - Lwt.return [(media, Printf.sprintf "@import url(%s);" href)] + if !Eliom_config.debug_timings + then Firebug.console ## (time (Js.string ("rewrite_CSS: " ^ href))); + let%lwt imports, css = + rewrite_css_import ~max ~prefix:(basedir href) ~media css 0 + in + if !Eliom_config.debug_timings + then Firebug.console ## (timeEnd (Js.string ("rewrite_CSS: " ^ href))); + Lwt.return (imports @ [media, css]) + with _ -> Lwt.return [media, Printf.sprintf "@import url(%s);" href] and rewrite_css_import ?(charset = "") ~max ~prefix ~media css pos = match Regexp.search import_re css pos with | None -> - (* No @import anymore, rewrite url. *) - Lwt.return ([], rewrite_css_url ~prefix css pos) - | Some (i, res) -> - (* Found @import rule, try to preload. *) - let init = String.sub css pos (i - pos) in - let charset = if pos = 0 then init else charset in - try - let i = i + String.length (Regexp.matched_string res) in - let i, href = parse_url ~prefix css i in - let i, media' = parse_media css i in - let%lwt import = - if max = 0 then - (* Maximum imbrication of @import reached, rewrite url. *) - Lwt.return [(media, - Printf.sprintf "@import url('%s') %s;\n" href media')] - else if media##.length > 0 && String.length media' > 0 then - (* TODO combine media if possible... - in the mean time keep explicit import. *) - Lwt.return [(media, - Printf.sprintf "@import url('%s') %s;\n" href media')] - else - let media = - if media##.length > 0 then media else Js.string media' - in - let css = - Eliom_request.http_get href [] Eliom_request.string_result in - rewrite_css ~max:(max-1) (media, href, css >|= snd) - and imports, css = - rewrite_css_import ~charset ~max ~prefix ~media css i in - Lwt.return (import @ imports, css) - with - | Incorrect_url -> - Lwt.return ([], rewrite_css_url ~prefix css pos) - | exn -> - Lwt_log.ign_info ~section ~exn "Error while importing css"; + (* No @import anymore, rewrite url. *) Lwt.return ([], rewrite_css_url ~prefix css pos) + | Some (i, res) -> ( + (* Found @import rule, try to preload. *) + let init = String.sub css pos (i - pos) in + let charset = if pos = 0 then init else charset in + try + let i = i + String.length (Regexp.matched_string res) in + let i, href = parse_url ~prefix css i in + let i, media' = parse_media css i in + let%lwt import = + if max = 0 + then + (* Maximum imbrication of @import reached, rewrite url. *) + Lwt.return + [media, Printf.sprintf "@import url('%s') %s;\n" href media'] + else if media##.length > 0 && String.length media' > 0 + then + (* TODO combine media if possible... + in the mean time keep explicit import. *) + Lwt.return + [media, Printf.sprintf "@import url('%s') %s;\n" href media'] + else + let media = + if media##.length > 0 then media else Js.string media' + in + let css = + Eliom_request.http_get href [] Eliom_request.string_result + in + rewrite_css ~max:(max - 1) (media, href, css >|= snd) + and imports, css = + rewrite_css_import ~charset ~max ~prefix ~media css i + in + Lwt.return (import @ imports, css) + with + | Incorrect_url -> Lwt.return ([], rewrite_css_url ~prefix css pos) + | exn -> + Lwt_log.ign_info ~section ~exn "Error while importing css"; + Lwt.return ([], rewrite_css_url ~prefix css pos)) let max_preload_depth = ref 4 @@ -625,17 +642,18 @@ let build_style (e, css) = (* lwt css = *) Lwt_list.map_p (fun (media, css) -> - let style = Dom_html.createStyle Dom_html.document in - style##._type := Js.string "text/css"; - style##.media := media; - (* IE8: Assigning to style##innerHTML results in + let style = Dom_html.createStyle Dom_html.document in + style##._type := Js.string "text/css"; + style##.media := media; + (* IE8: Assigning to style##innerHTML results in "Unknown runtime error" *) - let styleSheet = Js.Unsafe.(get style (Js.string "styleSheet")) in - if Js.Optdef.test styleSheet - then Js.Unsafe.(set styleSheet (Js.string "cssText") (Js.string css)) - else style##.innerHTML := Js.string css; - Lwt.return (e, (style :> Dom.node Js.t))) + let styleSheet = Js.Unsafe.(get style (Js.string "styleSheet")) in + if Js.Optdef.test styleSheet + then Js.Unsafe.(set styleSheet (Js.string "cssText") (Js.string css)) + else style##.innerHTML := Js.string css; + Lwt.return (e, (style :> Dom.node Js.t))) css + (* IE8 doesn't allow appendChild on noscript-elements *) (* (\* Noscript is used to group style. It's ignored by the parser when *) (* scripting is enabled, but does not seems to be ignore when *) @@ -646,17 +664,19 @@ let build_style (e, css) = let preload_css (doc : Dom_html.element Js.t) = if !Eliom_config.debug_timings - then Firebug.console##(time (Js.string "preload_css (fetch+rewrite)")); + then Firebug.console ## (time (Js.string "preload_css (fetch+rewrite)")); let%lwt css = Lwt_list.map_p build_style (fetch_linked_css (get_head doc)) in let css = List.concat css in - List.iter (fun (e, css) -> - try Dom.replaceChild (get_head doc) css e - with _ -> - (* Node was a unique node that has been removed... + List.iter + (fun (e, css) -> + try Dom.replaceChild (get_head doc) css e + with _ -> + (* Node was a unique node that has been removed... in a perfect settings we won't have parsed it... *) - Lwt_log.ign_info ~section "Unique CSS skipped...") css; + Lwt_log.ign_info ~section "Unique CSS skipped...") + css; if !Eliom_config.debug_timings - then Firebug.console##(timeEnd (Js.string "preload_css (fetch+rewrite)")); + then Firebug.console ## (timeEnd (Js.string "preload_css (fetch+rewrite)")); Lwt.return_unit (** Window scrolling *) @@ -665,26 +685,16 @@ let preload_css (doc : Dom_html.element Js.t) = Dom_html.document##body while on Firefox they are found on Dom_html.document##documentElement. *) -type position = { - html_top: int; - html_left: int; - body_top: int; - body_left: int; -} - -let top_position = { - html_top = 0; - html_left = 0; - body_top = 0; - body_left = 0; -} - -let createDocumentScroll () = { - html_top = Dom_html.document##.documentElement##.scrollTop; - html_left = Dom_html.document##.documentElement##.scrollLeft; - body_top = Dom_html.document##.body##.scrollTop; - body_left = Dom_html.document##.body##.scrollLeft; -} +type position = + {html_top : int; html_left : int; body_top : int; body_left : int} + +let top_position = {html_top = 0; html_left = 0; body_top = 0; body_left = 0} + +let createDocumentScroll () = + { html_top = Dom_html.document##.documentElement##.scrollTop + ; html_left = Dom_html.document##.documentElement##.scrollLeft + ; body_top = Dom_html.document##.body##.scrollTop + ; body_left = Dom_html.document##.body##.scrollLeft } (* With firefox, the scroll position is restored before to fire the popstate event. We maintain our own position. *) @@ -695,14 +705,15 @@ let _ = (* HACK: Remove this when js_of_ocaml 1.1.2 or greater is released... *) (* window##onscroll <- *) ignore - (Dom.addEventListener Dom_html.document - (Dom.Event.make "scroll") + (Dom.addEventListener Dom_html.document (Dom.Event.make "scroll") (Dom_html.handler (fun _event -> - current_position := createDocumentScroll (); - Js._false)) - Js._true : Dom_html.event_listener_id) + current_position := createDocumentScroll (); + Js._false)) + Js._true + : Dom_html.event_listener_id) let getDocumentScroll () = !current_position + let setDocumentScroll pos = Dom_html.document##.documentElement##.scrollTop := pos.html_top; Dom_html.document##.documentElement##.scrollLeft := pos.html_left; @@ -716,11 +727,12 @@ let setDocumentScroll pos = let touch_base () = Js.Opt.iter (Js.Opt.bind - (Dom_html.document##(getElementById - (Js.string Eliom_common_base.base_elt_id))) + Dom_html.document + ## (getElementById (Js.string Eliom_common_base.base_elt_id)) Dom_html.CoerceTo.base) - (fun e -> let href = e##.href in e##.href := href) - + (fun e -> + let href = e##.href in + e##.href := href) (* BEGIN FORMDATA HACK: This is only needed if FormData is not available in the browser. When it will be commonly available, remove all sections marked by "FORMDATA HACK" ! @@ -739,17 +751,20 @@ let touch_base () = let onclick_on_body_handler event = (match Dom_html.tagged (Dom_html.eventTarget event) with - | Dom_html.Button button -> - Js.Unsafe.global##.eliomLastButton := Some button; - | Dom_html.Input input when input##._type = Js.string "submit" -> - Js.Unsafe.global##.eliomLastButton := Some input; - | _ -> Js.Unsafe.global##.eliomLastButton := None); + | Dom_html.Button button -> Js.Unsafe.global##.eliomLastButton := Some button + | Dom_html.Input input when input##._type = Js.string "submit" -> + Js.Unsafe.global##.eliomLastButton := Some input + | _ -> Js.Unsafe.global##.eliomLastButton := None); Js._true let add_formdata_hack_onclick_handler () = - ignore (Dom_html.addEventListener (Dom_html.window##.document##.body) - Dom_html.Event.click (Dom_html.handler onclick_on_body_handler) - Js._true : Dom_html.event_listener_id) + ignore + (Dom_html.addEventListener + Dom_html.window##.document##.body + Dom_html.Event.click + (Dom_html.handler onclick_on_body_handler) + Js._true + : Dom_html.event_listener_id) (* END FORMDATA HACK *) @@ -760,16 +775,20 @@ let hashchange = Dom.Event.make "hashchange" let onhashchange f = if test_onhashchange () then - ignore (Dom.addEventListener Dom_html.window - hashchange ( Dom_html.handler (fun _ -> - f Dom_html.window##.location##.hash; Js._false) ) - Js._true : Dom_html.event_listener_id) + ignore + (Dom.addEventListener Dom_html.window hashchange + (Dom_html.handler (fun _ -> + f Dom_html.window##.location##.hash; + Js._false)) + Js._true + : Dom_html.event_listener_id) else let last_fragment = ref Dom_html.window##.location##.hash in let check () = if !last_fragment != Dom_html.window##.location##.hash - then - (last_fragment := Dom_html.window##.location##.hash; - f Dom_html.window##.location##.hash) in - ignore (Dom_html.window##(setInterval (Js.wrap_callback check) - (0.2 *. 1000.))) + then ( + last_fragment := Dom_html.window##.location##.hash; + f Dom_html.window##.location##.hash) + in + ignore + Dom_html.window ## (setInterval (Js.wrap_callback check) (0.2 *. 1000.)) diff --git a/src/lib/client/eliommod_dom.mli b/src/lib/client/eliommod_dom.mli index fd1e2eedb6..75a845e0a7 100644 --- a/src/lib/client/eliommod_dom.mli +++ b/src/lib/client/eliommod_dom.mli @@ -21,9 +21,11 @@ open Js_of_ocaml -class type ['element] get_tag = object - method getElementsByTagName : Js.js_string Js.t -> 'element Dom.nodeList Js.t Js.meth -end +class type ['element] get_tag = + object + method getElementsByTagName : + Js.js_string Js.t -> 'element Dom.nodeList Js.t Js.meth + end val get_body : 'element #get_tag Js.t -> 'element Js.t val get_head : 'element #get_tag Js.t -> 'element Js.t @@ -36,61 +38,67 @@ val get_head : 'element #get_tag Js.t -> 'element Js.t * nodes with closures ( events ) * nodes with attributes *) -val select_nodes : Dom_html.element Js.t -> - Dom_html.anchorElement Dom.nodeList Js.t - * Dom_html.formElement Dom.nodeList Js.t - * Dom_html.element Dom.nodeList Js.t - * Dom_html.element Dom.nodeList Js.t - * Dom_html.element Dom.nodeList Js.t - +val select_nodes + : Dom_html.element Js.t + -> Dom_html.anchorElement Dom.nodeList Js.t + * Dom_html.formElement Dom.nodeList Js.t + * Dom_html.element Dom.nodeList Js.t + * Dom_html.element Dom.nodeList Js.t + * Dom_html.element Dom.nodeList Js.t + +val select_request_nodes + : Dom_html.element Js.t + -> Dom_html.element Dom.nodeList Js.t (** [select_request_nodes root] finds the nodes below [root] in the page annotated to be: * request unique nodes *) -val select_request_nodes : Dom_html.element Js.t -> - Dom_html.element Dom.nodeList Js.t -(** [ancessor n1 n2] is true if [n1] is an ancessor of [n2] *) val ancessor : #Dom.node Js.t -> #Dom.node Js.t -> bool +(** [ancessor n1 n2] is true if [n1] is an ancessor of [n2] *) val createEvent : Js.js_string Js.t -> #Dom_html.event Js.t +val copy_element + : Dom.element Js.t + -> (Js.js_string Js.t -> bool) + -> Dom_html.element Js.t (** [copy_element e] creates recursively a fresh html from any xml element avoiding browser bugs *) -val copy_element : Dom.element Js.t -> - (Js.js_string Js.t -> bool) -> Dom_html.element Js.t +val html_document + : Dom.element Dom.document Js.t + -> (Js.js_string Js.t -> bool) + -> Dom_html.element Js.t (** Assuming [d] has a body and head element, [html_document d] will return the same document as html *) -val html_document : Dom.element Dom.document Js.t -> - (Js.js_string Js.t -> bool) -> Dom_html.element Js.t +val preload_css : Dom_html.element Js.t -> unit Lwt.t (** [preload_css e] downloads every css included in every link elements that is a descendant of [e] and replace it and its linked css by inline [