Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Support
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
H
Heritage_Platform
Project overview
Project overview
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
0
Issues
0
List
Boards
Labels
Milestones
Merge Requests
0
Merge Requests
0
Packages
Packages
Container Registry
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Commits
Issue Boards
Open sidebar
Gérard Huet
Heritage_Platform
Commits
18baa957
Commit
18baa957
authored
Jan 16, 2019
by
Gérard Huet
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Cleanups
parent
a44d5094
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
12 additions
and
16 deletions
+12
-16
ML/html.ml
ML/html.ml
+12
-16
No files found.
ML/html.ml
View file @
18baa957
...
...
@@ -15,10 +15,11 @@
(* 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)] *)
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
[
[]
->
""
...
...
@@ -90,7 +91,7 @@ value rec print_options = fun
value
rec
print_options_default
=
fun
[
[]
->
""
|
[
(
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
=
...
...
@@ -110,12 +111,12 @@ value text_input id control =
xml_empty_with_att
"input"
[
(
"id"
,
id
);
(
"type"
,
"text"
);
(
"name"
,
control
)
]
;
value
add_opt_attrs
opt_attrs
attrs
=
List
.
fold_left
(
fun
acc
(
label
,
v
)
->
let
add_attr
acc
(
label
,
v
)
=
match
v
with
[
None
->
acc
|
Some
v
->
[
(
label
,
v
)
::
acc
]
]
)
attrs
opt_attrs
]
in
List
.
fold_left
add_attr
attrs
opt_attrs
;
value
int_input
?
id
?
val
?
(
step
=
1
)
?
(
min
=
min_int
)
?
(
max
=
max_int
)
name
=
let
attrs
=
...
...
@@ -201,7 +202,6 @@ type basic_style =
|
Tablecenter
|
Color
of
color
|
Bgcolor
of
color
(*| Bgpict of pict *)
|
Position
of
string
|
Full_width
|
Height
of
int
...
...
@@ -298,7 +298,6 @@ value style_sheet = fun
|
Textalign
p
->
"text-align:"
^
justify
p
|
Color
cl
->
"color:"
^
rgb
cl
|
Bgcolor
cl
->
"background-color:"
^
rgb
cl
(*[| Bgpict p -> "background-image:url(" ^ pict p ^ ")" ]*)
|
Position
pos
->
pos
|
Tablecenter
->
"margin:0 auto"
|
No_border
->
"border: 0"
...
...
@@ -320,7 +319,7 @@ value enpied = "position: fixed; bottom: 0pt; width: 100%"
(* All the styles of the various sections - terminology to be streamlined *)
(* NB: When [style_class] is changed, module Css ought to be adapted *)
type
style_class
=
[
Blue_
|
Green_
|
Navy_
|
Red_
|
Magenta_
[
Blue_
|
Green_
|
Navy_
|
Red_
|
Magenta_
|
Hidden_
|
Header_deva
|
Header_tran
|
Bandeau
|
Body
|
Spacing20
|
Pad60
|
Border2
|
Latin12
|
Trans12
|
Deva
|
Devac
|
Deva16
|
Deva16c
|
Deva20c
|
Roma16o
|
Roma12o
|
Inflexion
...
...
@@ -331,7 +330,7 @@ type style_class =
|
Pink_back
|
Chamois_back
|
Cyan_back
|
Brown_back
|
Lime_back
|
Grey_back
|
Deep_sky_back
|
Carmin_back
|
Orange_back
|
Red_back
|
Mauve_back
|
Lavender_back
|
Lavender_cent
|
Green_back
|
Lawngreen_back
|
Magenta_back
|
Aquamarine_back
|
Hidden_
|
Aquamarine_back
]
;
value
background
=
fun
...
...
@@ -520,7 +519,7 @@ value class_of = fun
]
;
(* 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
=
let
style_attr
=
(* if Install.css then *)
(
"class"
,
class_of
cl
)
(* else ("style",style cl) *)
in
...
...
@@ -786,13 +785,10 @@ value escape s =
]
in
let
escape
s
=
try
"&"
^
List
.
assoc
s
conversion_tbl
^
";"
with
[
Not_found
->
s
]
in
try
"&"
^
List
.
assoc
s
conversion_tbl
^
";"
with
[
Not_found
->
s
]
in
let
special_chars
=
Str
.
regexp
(
"["
^
String
.
concat
""
(
conversion_tbl
|>
List
.
split
|>
fst
)
^
" "
^
"]"
)
in
"["
^
String
.
concat
""
(
conversion_tbl
|>
List
.
split
|>
fst
)
^
" ]"
)
in
let
subst
s
=
s
|>
Str
.
matched_string
|>
escape
in
Str
.
global_substitute
special_chars
subst
s
;
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment