Commit 18baa957 authored by Gérard Huet's avatar Gérard Huet

Cleanups

parent a44d5094
...@@ -15,10 +15,11 @@ ...@@ -15,10 +15,11 @@
(* Generic HTML scripting *) (* Generic HTML scripting *)
(**************************) (**************************)
(* All values are pure, not side-effect, no printing. *) (* All values are pure, with no side-effect, no printing. *)
(* Attributes given as association lists [(label,value): (string * string)] *) (* Attributes given as association lists [(label,value): (string * string)] *)
value assoc_quote (label,valu) = value assoc_quote (label,valu) =
let sp_label = " " ^ label in sp_label ^ "=\"" ^ valu ^ "\"" let sp_label = " " ^ label in
sp_label ^ "=\"" ^ valu ^ "\""
; ;
value rec quote_alist = fun value rec quote_alist = fun
[ [] -> "" [ [] -> ""
...@@ -90,7 +91,7 @@ value rec print_options = fun ...@@ -90,7 +91,7 @@ value rec print_options = fun
value rec print_options_default = fun value rec print_options_default = fun
[ [] -> "" [ [] -> ""
| [ (control,id,b) :: rest ] -> | [ (control,id,b) :: rest ] ->
option_print_default id control b ^ print_options_default rest (option_print_default id control b) ^ (print_options_default rest)
] ]
; ;
value option_select list_options = value option_select list_options =
...@@ -110,12 +111,12 @@ value text_input id control = ...@@ -110,12 +111,12 @@ value text_input id control =
xml_empty_with_att "input" [ ("id",id); ("type","text"); ("name",control) ] xml_empty_with_att "input" [ ("id",id); ("type","text"); ("name",control) ]
; ;
value add_opt_attrs opt_attrs attrs = value add_opt_attrs opt_attrs attrs =
List.fold_left (fun acc (label, v) -> let add_attr acc (label, v) =
match v with match v with
[ None -> acc [ None -> acc
| Some v -> [ (label, v) :: acc ] | Some v -> [ (label, v) :: acc ]
] ] in
) attrs opt_attrs List.fold_left add_attr attrs opt_attrs
; ;
value int_input ?id ?val ?(step = 1) ?(min = min_int) ?(max = max_int) name = value int_input ?id ?val ?(step = 1) ?(min = min_int) ?(max = max_int) name =
let attrs = let attrs =
...@@ -201,7 +202,6 @@ type basic_style = ...@@ -201,7 +202,6 @@ type basic_style =
| Tablecenter | Tablecenter
| Color of color | Color of color
| Bgcolor of color | Bgcolor of color
(*| Bgpict of pict *)
| Position of string | Position of string
| Full_width | Full_width
| Height of int | Height of int
...@@ -298,7 +298,6 @@ value style_sheet = fun ...@@ -298,7 +298,6 @@ value style_sheet = fun
| Textalign p -> "text-align:" ^ justify p | Textalign p -> "text-align:" ^ justify p
| Color cl -> "color:" ^ rgb cl | Color cl -> "color:" ^ rgb cl
| Bgcolor cl -> "background-color:" ^ rgb cl | Bgcolor cl -> "background-color:" ^ rgb cl
(*[| Bgpict p -> "background-image:url(" ^ pict p ^ ")" ]*)
| Position pos -> pos | Position pos -> pos
| Tablecenter -> "margin:0 auto" | Tablecenter -> "margin:0 auto"
| No_border -> "border: 0" | No_border -> "border: 0"
...@@ -320,7 +319,7 @@ value enpied = "position: fixed; bottom: 0pt; width: 100%" ...@@ -320,7 +319,7 @@ value enpied = "position: fixed; bottom: 0pt; width: 100%"
(* All the styles of the various sections - terminology to be streamlined *) (* All the styles of the various sections - terminology to be streamlined *)
(* NB: When [style_class] is changed, module Css ought to be adapted *) (* NB: When [style_class] is changed, module Css ought to be adapted *)
type style_class = type style_class =
[ Blue_ | Green_ | Navy_ | Red_ | Magenta_ [ Blue_ | Green_ | Navy_ | Red_ | Magenta_ | Hidden_
| Header_deva | Header_tran | Bandeau | Body | Spacing20 | Pad60 | Border2 | Header_deva | Header_tran | Bandeau | Body | Spacing20 | Pad60 | Border2
| Latin12 | Trans12 | Deva | Devac | Deva16 | Deva16c | Deva20c | Latin12 | Trans12 | Deva | Devac | Deva16 | Deva16c | Deva20c
| Roma16o | Roma12o | Inflexion | Roma16o | Roma12o | Inflexion
...@@ -331,7 +330,7 @@ type style_class = ...@@ -331,7 +330,7 @@ type style_class =
| Pink_back | Chamois_back | Cyan_back | Brown_back | Lime_back | Grey_back | Pink_back | Chamois_back | Cyan_back | Brown_back | Lime_back | Grey_back
| Deep_sky_back | Carmin_back | Orange_back | Red_back | Mauve_back | Deep_sky_back | Carmin_back | Orange_back | Red_back | Mauve_back
| Lavender_back | Lavender_cent | Green_back | Lawngreen_back | Magenta_back | Lavender_back | Lavender_cent | Green_back | Lawngreen_back | Magenta_back
| Aquamarine_back | Hidden_ | Aquamarine_back
] ]
; ;
value background = fun value background = fun
...@@ -520,7 +519,7 @@ value class_of = fun ...@@ -520,7 +519,7 @@ value class_of = fun
] ]
; ;
(* Allows css style compiling even when browser does not support css *) (* Allows css style compiling even when browser does not support css *)
(* This support was necessary for Simputer platform *) (* This support was necessary for Simputer platform - now deprecated *)
value elt_begin_attrs attrs elt cl = value elt_begin_attrs attrs elt cl =
let style_attr = (* if Install.css then *) ("class",class_of cl) let style_attr = (* if Install.css then *) ("class",class_of cl)
(* else ("style",style cl) *) in (* else ("style",style cl) *) in
...@@ -786,13 +785,10 @@ value escape s = ...@@ -786,13 +785,10 @@ value escape s =
] ]
in in
let escape s = let escape s =
try "&" ^ List.assoc s conversion_tbl ^ ";" with [ Not_found -> s ] try "&" ^ List.assoc s conversion_tbl ^ ";" with [ Not_found -> s ] in
in
let special_chars = let special_chars =
Str.regexp ( Str.regexp (
"[" ^ String.concat "" (conversion_tbl |> List.split |> fst) ^ " " ^ "]" "[" ^ String.concat "" (conversion_tbl |> List.split |> fst) ^ " ]") in
)
in
let subst s = s |> Str.matched_string |> escape in let subst s = s |> Str.matched_string |> escape in
Str.global_substitute special_chars subst s Str.global_substitute special_chars subst s
; ;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment