Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

1283 lines (1138 sloc) 45.33 kB
/*
Copyright © 2011 MLstate
This file is part of Opa.
Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
*/
/*
@authors ?
**/
import stdlib.core.{web.core, map, color}
/**
* Definition of the main OPA types for CSS.
*
* @category WEB
* @destination PRIVATE?
* @stability UNSTABLE -- NEEDS REWRITE
*/
/**
* {1 About this module}
*
* This module provides the basic type definitions for the CSS (see {{:http://www.w3.org/TR/CSS2/} the full specification})
* data structure, together with some handling functions.
*
* {1 Where do I start}
*
* The main part of this file is the definition of the CSS properties ({!Css.unary}). These
* have a simple correspondence with css2, described below.
*
* This module is transitional and will soon be replaced by a better structured approach.
*
* {1 what if i need more?}
*/
type Css.compiled_property = {name: string; value:string}
/**
* {1 Css_private interface}
*/
Css_private =
{{
order = Order.make_unsafe(compare) : order(Css.entry, Css.order)
Entry_map = Map_make(order)
Entry_map_empty : ordered_map(Css.entry, stringmap(list(Css.prop_value_item)), Css.order) = Entry_map.empty
Entry_map_add(k:list, data:map(string,'b), m:ordered_map(Css.entry, map(string,'b), Css.order)) =
match Entry_map.get(k, m)
| {~some} -> Entry_map.add(k, StringMap.union(data, some), m)
| {none} -> Entry_map.add(k, data, m)
}}
@opacapi
__internal__add_css_entry = Css_private.Entry_map_add
/**
* {1 Css_printer interface}
*/
Css_printer =
{{
set(lst, old) =
eq(old, new) = match (old, new) with
// FIXME This is bound to be (get) wrong...
| ({ background = _ }, { background = _ }) -> true
| ({ border = _ }, { border = _ }) -> true
| ({ border_collapse = _}, {border_collapse = _}) -> true
| ({ border_spacing = _}, {border_spacing = _}) -> true
| ({ color = _ }, { color = _ }) -> true
| ({ cursor = _ }, { cursor = _ }) -> true
| ({ direction = _ }, { direction = _ }) -> true
| ({ display = _ }, { display = _ }) -> true
| ({ float = _ }, { float = _ }) -> true
| ({ font = _ }, { font = _ }) -> true
| ({ font_family = _ }, { font_family = _ }) -> true
| ({ font_size = _ }, { font_size = _ }) -> true
| ({ font_decoration = _ }, { font_decoration = _ }) -> true
| ({ height = _ }, { height = _ }) -> true
| ({ left = _ }, { left = _ }) -> true
| ({ letter_spacing = _ }, { letter_spacing = _ }) -> true
| ({ line_height = _ }, { line_height = _ }) -> true
| ({ list_style = _ }, { list_style = _ }) -> true
| ({ margin = _ }, { margin = _ }) -> true
| ({ overflow = _ }, { overflow = _ }) -> true
| ({ padding = _ }, { padding = _ }) -> true
| ({ position = _ }, { position = _ }) -> true
| ({ table_layout = _ }, { table_layout = _ }) -> true
| ({ text_align = _ }, { text_align = _ }) -> true
| ({ top = _ }, { top = _ }) -> true
| ({ visibility = _ }, { visibility = _ }) -> true
| ({ width = _ }, { width = _ }) -> true
| ({ white_space = _ }, { white_space = _ }) -> true
| ({ z_index = _ }, { z_index = _ }) -> true
| _ -> false
rec bar(lst, prop, accu) =
match lst with
| [hd | tl] ->
if eq(prop, hd) then (hd, List.append(tl, accu))
else bar(tl, prop, List.cons(hd, accu))
| [] -> (prop, accu)
rec foo(add, old, accu) =
match old : list with
| [hd | tl] ->
(prop, add) = bar(add, hd, [])
foo(add, tl, List.cons(prop, accu))
| [] -> List.append(accu, add)
foo(lst, old, [])
concat(x) = String.concat(" ", x)
css_property(name, value) = ~{ name value }
css_properties(name, value) = [ css_property(name, value) ]
property_of_option(s,o) =
match o with
| { none } -> []
| { ~some } -> css_properties(s,some)
to_xhtml_style(style: Css.properties): list(Css.compiled_property) =
get_list_sep(get_alpha,sep,l) =
List.foldl(( e,str -> str ^ get_alpha(e) ^ sep ),l,"")
get_list(get_alpha,l) =
get_list_sep(get_alpha," ",l)
get_option(get_alpha,o) =
Option.map(get_alpha,o) ? ""
get_color(color) = Color.color_to_string(color)
get_url(url:url) = "url(\"{Url.encode(url)}\")"
get_z_index =
| { none } -> "auto"
| { ~some } -> "{some:int}"
get_size(x:Css.size):string = match x
| { ~cm } -> "{cm}cm"
| { ~em } -> "{em}em"
| { ~ex } -> "{ex}ex"
| { ~inch } -> "{inch}in"
| { ~mm } -> "{mm}mm"
| { ~percent } -> "{percent}%"
| { ~pc } -> "{pc}pc"
| { ~pt } -> "{pt}pt"
| { ~px } -> "{px}px"
get_size_or_normal(x:Css.size_or_normal):string = match x
| { normal } -> "normal"
| { ~size } -> get_size(size)
get_size_or_none(x:Css.size_or_none):string = match x
| { none } -> "none"
| { ~size } -> get_size(size)
get_white_space =
| { normal } -> "normal"
| { pre } -> "pre"
| { nowrap } -> "nowrap"
get_align =
| { left } -> "left"
| { right } -> "right"
| { center } -> "center"
| { justify } -> "justify"
get_style_position =
| { inside } -> "inside"
| { outside } -> "outside"
get_case =
| { upper_case } -> "upper"
| { lower_case } -> "lower"
get_list_style_def =
| { ~image } -> get_url(image)
| { disc } -> "disc"
| { square } -> "square"
| { decimal = { leading } } -> "decimal-leading-zero"
| { decimal = { not_leading } } -> "decimal"
| { ~roman } -> get_case(roman) ^ "-roman"
| { ~latin } -> get_case(latin) ^ "-latin"
| { greek } -> "lower-greek"
get_list_style({ ~style_position ~style } as l) =
if Css_build.no_list_style == l then
none
else
some(concat([get_option(get_style_position,style_position),
get_option(get_list_style_def,style)
]))
get_visibility =
| { visible } -> "visible"
| { hidden } -> "hidden"
get_direction =
| { left_to_right } -> "ltr"
| { right_to_left } -> "rtl"
get_float =
| { left } -> "left"
| { right } -> "right"
| { css_none } -> "none"
get_position =
| { absolute } -> "absolute"
| { relative } -> "relative"
| { fixed } -> "fixed"
| { static } -> "static"
get_cursor_resize =
| { n } -> "n-resize"
| { s } -> "s-resize"
| { e } -> "e-resize"
| { w } -> "w-resize"
| { ne } -> "ne-resize"
| { nw } -> "nw-resize"
| { se } -> "se-resize"
| { sw } -> "sw-resize"
get_default_cursor =
| { pointer } -> "pointer"
| { auto } /* default */ -> "auto"
| { default } -> "default"
| { crosshair } -> "crosshair"
| { progress } -> "progress"
| { move } -> "move"
| { text } -> "text"
| { ~resize } -> get_cursor_resize(resize)
| { help } -> "help"
| { wait } -> "wait"
get_cursor({ ~icons ~default}) =
concat([get_list_sep(get_url,",",icons), get_default_cursor(default)])
get_decoration =
| { italic } -> "italic"
| { bold } -> "bold"
| { underline }
| { overline }
| { line_through } -> error("CSS::to_xhtml_style: Unexpected underline/overline/line-through in font")
| { small_caps } -> "small_caps"
| { normal } -> "normal"
get_font_family =
//quote(s) = "\"" ^ s ^ "\""
//(s -> if List.exists(_ == ' ', String.to_list(s)) then quote(s) else s) @
| { TimesNewRoman } -> "Cambria, \"Hoefler Text\", Utopia, \"Liberation Serif\", \"Nimbus Roman No9 L Regular\", Times, \"Times New Roman\", serif"
| { Georgia } -> "Constantia, \"Lucida Bright\", Lucidabright, \"Lucida Serif\", Lucida, \"DejaVu Serif,\" \"Bitstream Vera Serif\", \"Liberation Serif\", Georgia, serif"
| { Garamond } -> "\"Palatino Linotype\", Palatino, Palladio, \"URW Palladio L\", \"Book Antiqua\", Baskerville, \"Bookman Old Style\", \"Bitstream Charter\", \"Nimbus Roman No9 L\", Garamond, \"Apple Garamond\", \"ITC Garamond Narrow\", \"New Century Schoolbook\", \"Century Schoolbook\", \"Century Schoolbook L\", Georgia, serif"
| { Helvetica } -> "Frutiger, \"Frutiger Linotype\", Univers, Calibri, \"Gill Sans\", \"Gill Sans MT\", \"Myriad Pro\", Myriad, \"DejaVu Sans Condensed\", \"Liberation Sans\", \"Nimbus Sans L\", Tahoma, Geneva, \"Helvetica Neue\", Helvetica, Arial, sans-serif"
| { Verdana } -> "Corbel, \"Lucida Grande\", \"Lucida Sans Unicode\", \"Lucida Sans\", \"DejaVu Sans\", \"Bitstream Vera Sans\", \"Liberation Sans\", Verdana, \"Verdana Ref\", sans-serif"
| { Trebuchet } -> "\"Segoe UI\", Candara, \"Bitstream Vera Sans\", \"DejaVu Sans\", \"Bitstream Vera Sans\", \"Trebuchet MS\", Verdana, \"Verdana Ref\", sans-serif"
| { HeavyImpact } -> "Impact, Haettenschweiler, \"Franklin Gothic Bold\", Charcoal, \"Helvetica Inserat\", \"Bitstream Vera Sans Bold\", \"Arial Black\", sans-serif"
| { Monospace } -> "Consolas, \"Andale Mono WT\", \"Andale Mono\", \"Lucida Console\", \"Lucida Sans Typewriter\", \"DejaVu Sans Mono\", \"Bitstream Vera Sans Mono\", \"Liberation Mono\", \"Nimbus Mono L\", Monaco, \"Courier New\", Courier, monospace"
get_font({ ~size ~line_height ~family ~decoration}) =
concat([get_list(get_decoration,decoration),
get_size(size),
"/",
get_size_or_normal(line_height),
get_font_family(family)])
get_display =
| { block } -> "block"
| { inline } -> "inline"
| { inline_block } -> "inline-block"
| { css_none } -> "none"
get_overflow =
| { hidden } -> "hidden"
| { visible } -> "visible"
| { scroll } -> "scroll"
| { auto } -> "auto"
get_block_size(prefix, {~t ~l ~b ~r}) =
f((local_prefix,v)) =
Option.map(v -> css_property(prefix ^ "-" ^ local_prefix, get_size(v)), v)
List.filter_map(f, [("top",t),("bottom",b),("left",l),("right",r)])
get_border_style_elt =
| { css_none } -> "none"
| { hidden } -> "hidden"
| { dotted } -> "dotted"
| { dashed } -> "dashed"
| { solid } -> "solid"
| { double } -> "double"
| { groove } -> "groove"
| { ridge } -> "ridge"
| { inset} -> "inset"
| { outset } -> "outset"
get_border_thickness =
| { thin } -> "thin"
| { medium } -> "medium"
| { thick } -> "thick"
| { ~size } -> get_size(size)
get_vertical_align =
| { middle } -> "middle"
| { baseline } -> "baseline"
get_border_type({~style ~width ~color} as v) =
if v == Css_build.no_border_type then
none
else
some(concat([get_option(get_border_style_elt,style),
get_option(get_border_thickness,width),
get_option(get_color,color),
]))
get_border_collapse =
| { collapse } -> "collapse"
| { separate } -> "separate"
| { inherit } -> "inherit"
get_table_layout =
| { auto } -> "auto"
| { fixed } -> "fixed"
| { inherit } -> "inherit"
get_repeat =
| { x } -> "repeat-x"
| { y } -> "repeat-y"
| { css_none } -> "no-repeat"
| { both } -> "repeat"
get_background_position_y =
| { center } -> "center"
| { top } -> "top"
| { bottom } -> "bottom"
| { ~size } -> get_size(size)
get_background_position_x =
| { center } -> "center"
| { left } -> "left"
| { right } -> "right"
| { ~size } -> get_size(size)
get_attached(_) =
"fixed"
get_background_position({~x ~y}) =
"{get_background_position_y(y)} {get_background_position_x(x)}"
get_background({~url ~position ~repeat ~color ~attached} as b) =
if Css_build.no_background == b then
none
else
some(concat([get_option(get_url,url),
get_option(get_background_position,position),
get_option(get_repeat,repeat),
get_option(get_color,color),
get_option(get_attached,attached),
]))
get_font_decoration(font_decoration) =
is_text_dec(x) =
match x : Css.decoration with
| {overline} | {underline} | { line_through } -> {true}
| _ -> {false}
(over_under,others) = List.partition(is_text_dec,font_decoration)
l1 =
match List.unique_list_of(over_under) with
| [] -> []
| [hd] ->
match hd with
| { underline } -> css_properties("text-decoration","underline")
| { overline } -> css_properties("text-decoration","overline")
| { line_through } -> css_properties("text-decoration","line-through")
| _ -> error("CSS::to_xhtml_string: Compiler bug")
end
| _ -> css_properties("text-decoration","underline overline")
add_and_filter_out(name,v,l) = css_property(name,v) +> List.filter(x -> x.name != name, l)
f(font_decoration,acc) =
match font_decoration with
| { italic } ->
add_and_filter_out("font-style","italic",acc)
| { bold } ->
add_and_filter_out("font-weight","bold",acc)
| { underline }
| { overline }
| { line_through } -> error("CSS::to_xhtml_string: Compiler bug")
| { small_caps } ->
add_and_filter_out("font-variant","small-caps",acc)
| { normal } ->
[css_property("font-style","normal"),
css_property("font-weight","normal"),
css_property("font-variant","normal"),
]
end
l2 = List.rev(List.foldl(f,others,[]))
l1 ++ l2
get_font_variant =
| { normal } -> "normal"
| { inherit } -> "inherit"
| { small_caps} -> "small-caps"
get_opacity(o : float) =
oi = Int.of_float(o * 100.)
[ css_property("opacity", "{o}")
, css_property("filter", "alpha(opacity={oi})")
, css_property("-ms-filter", "progid:DXImageTransform.Microsoft.Alpha(opacity={oi})")
]
get_border_radius(border_radius : Css.size) =
br = get_size(border_radius)
[ css_property("border-radius", br)
, css_property("-moz-morder-radius", br)
, css_property("-webkit-border-radius", br)
]
rec aux(style) =
(match style: Css.unary with
| { ~background } ->
property_of_option("background",get_background(background))
| { border = (border,border_type) } ->
s = match border with
| { all } -> "border"
| { left } -> "border-left"
| { right } -> "border-right"
| { top } -> "border-top"
| { bottom } -> "border-bottom"
property_of_option(s, get_border_type(border_type))
| { ~border_collapse } -> css_properties("border-collapse", get_border_collapse(border_collapse))
| { ~border_radius } -> get_border_radius(border_radius)
| { ~border_spacing } -> css_properties("border-spacing", get_size(border_spacing))
| { ~bottom } -> css_properties("bottom", get_size(bottom))
| { ~color } -> css_properties("color", get_color(color))
| { ~cursor } -> css_properties("cursor", get_cursor(cursor))
| { ~direction } -> css_properties("direction", get_direction(direction))
| { ~display } -> css_properties("display", get_display(display))
| { ~float } -> css_properties("float", get_float(float))
| { ~font } ->
// treating decoration a special way because we might have overline and underline, which are not part of a 'font' declaration in CSS
css_properties("font", get_font({font with decoration=[]})) ++
aux({font_decoration = font.decoration})
| { ~font_family } -> css_properties("font-family", get_font_family(font_family))
| { ~font_size } -> css_properties("font-size", get_size(font_size))
| { ~font_decoration } -> get_font_decoration(font_decoration)
| { ~font_variant } -> css_properties("font-variant", get_font_variant(font_variant))
| { ~height } -> css_properties("height", get_size(height))
| { ~left } -> css_properties("left", get_size(left))
| { ~letter_spacing } -> css_properties("letter-spacing", get_size_or_normal(letter_spacing))
| { ~line_height } -> css_properties("line-height", get_size(line_height))
| { ~list_style } -> property_of_option("list-style",get_list_style(list_style))
| { ~margin } -> get_block_size("margin",margin)
| { ~max_height } -> css_properties("max-height", get_size_or_none(max_height))
| { ~min_height } -> css_properties("min-height", get_size_or_none(min_height))
| { ~max_width } -> css_properties("max-width", get_size_or_none(max_width))
| { ~min_width } -> css_properties("min-width", get_size_or_none(min_width))
| { ~overflow } -> css_properties("overflow", get_overflow(overflow))
| { ~opacity } -> get_opacity(opacity)
| { ~padding } -> get_block_size("padding",padding)
| { ~position } -> css_properties("position", get_position(position))
| { ~right } -> css_properties("right", get_size(right))
| { ~table_layout } -> css_properties("table-layout", get_table_layout(table_layout))
| { ~text_align } -> css_properties("text-align", get_align(text_align))
| { ~top } -> css_properties("top", get_size(top))
| { ~vertical_align } -> css_properties("vertical_align", get_vertical_align(vertical_align))
| { ~visibility } -> css_properties("visibility", get_visibility(visibility))
| { ~width } -> css_properties("width", get_size(width))
| { ~white_space } -> css_properties("white-space", get_white_space(white_space))
| { ~z_index } -> css_properties("z-index", get_z_index(z_index))
| { ~not_typed } -> css_properties(not_typed.f1, not_typed.f2)
| _ -> error("Css.to_xhtml_style::root"))
List.flatten(List.map(aux,style))
}}
/**
* The main type for css: describes CSS display properties.
*
* Includes many auxiliary types below
*/
type Css.unary =
{ background: Css.background }
/ { border: Css.border }
/ { border_collapse : Css.border_collapse }
/ { border_radius: Css.size }
/ { border_spacing: Css.size }
/ { bottom: Css.size }
/ { color: color }
/ { cursor: Css.cursor }
/ { direction: Css.direction }
/ { display: Css.display }
/ { float: Css.float }
/ { font: Css.font }
/ { font_family : Css.font_family }
/ { font_size: Css.size }
/ { font_decoration: list(Css.decoration) }
/ { font_variant: Css.font_variant }
/ { height: Css.size }
/ { left: Css.size }
/ { letter_spacing: Css.size_or_normal }
/ { line_height : Css.size }
/ { list_style: Css.list_style }
/ { margin: Css.block_size }
/ { max_height: Css.size_or_none }
/ { min_height: Css.size_or_none }
/ { max_width: Css.size_or_none }
/ { min_width: Css.size_or_none }
/ { opacity: float }
/ { overflow: Css.overflow }
/ { padding: Css.block_size }
/ { position: Css.position }
/ { right: Css.size }
/ { table_layout: Css.table_layout }
/ { text_align: Css.align }
/ { top: Css.size }
/ { visibility: Css.visibility }
/ { width: Css.size }
/ { white_space: Css.white_space }
/ { vertical_align: Css.vertical_align }
/ { z_index: option(int) }
/ { not_typed: (string,string) }
/*
we show the correspondence between Css.unary and css2 definitions
------------------------------------------------
css_unary css
-------------------------------------------------
background background
background-{color,attachment,image,position,repeat}
border border,border-{top,bottom,left,right}
bottom bottom
color color
cursor cursor
direction direction
display display
float float
font font,text-decoration
font_family font-family
font_size font-size
font_decoration font-variant,font-style,
font-weight,text-decoration
height height
left left
letter_spacing letter-spacing
list_style list-style,list-style-image
list-style-position,list-style-type
margin margin,margin-{top,bottom,left,right}
overflow overflow
padding padding,padding-{top,bottom,left,right}
position position
right right
text_align text-align
top top
visibility visibility
white_space white-space
z_index z-index
The properties that are different in css and in css_unary can be done the following way:
- background-color: blue -> background: blue
(etc. for background-attachment, background-image, ...)
- border-top: ... -> border({top},...)
(etc.)
- text-decoration: overline -> font_decoration: overline
- font-weight: bold -> font_decoration: bold
font-variant: small-caps -> font_decoration: small_caps
font-style: italic -> font_decoration: italic
- list-style-position: outside -> list-style: outside
(etc. pour list-style-*)
- margin-left: value -> margin(none,some(value),none,none)
(etc. pour margin-*)
- padding: works just like margin
For concrete syntax examples, see opa/test/style.opa
*/
// TODO: once possible, inline as many "small" sum types here into the Css.unary type
// ** BORDER-COLLAPSE ****************
type Css.border_collapse =
{ inherit }
/ { separate }
/ { collapse }
// ** TABLE-LAYOUT ****************
type Css.table_layout =
{ auto }
/ { fixed }
/ { inherit }
// ** VERTICAL-ALIGN ****************
type Css.vertical_align =
{ baseline } /* default */
/ { middle }
// ** WHITE-SPACE ****************
type Css.white_space =
{ normal } /* default */
/ { pre }
/ { nowrap }
// ** TEXT ALIGNM ****************
type Css.align =
{ left } /* default, i guess */
/ { center }
/ { right }
/ { justify }
// ** LIST STYLE ****************#
type Css.style_position =
{ inside }
/ { outside } /* default */
type Css.list_style = // should not have (none,none) (but the case is treated by to_xhtml_style anyway)
{ style_position: option(Css.style_position)
style : option(Css.list_style_def)
}
type Css.list_style_def =
{ image: url }
/ { disc } /* default */
/ { square }
/ { decimal: leading_zero}
/ { roman: case }
/ { greek }
/ { latin: case }
type case = { lower_case } / { upper_case }
type leading_zero =
{ leading } /* 01 02 ... 10 */
/ { not_leading } /* 1 2 ... 10 */
// ** DIRECTION ******************
type Css.direction =
{ right_to_left }
/ { left_to_right }
// ** VISIBILITY ****************#
type Css.visibility =
{ visible } /* default */
/ { hidden }
// ** FLOAT **********************
type Css.float =
{ left }
/ { right }
/ { css_none } /* default */ /* not "none" to avoid conflict with the option type. Would be nicer to embed this sum into the Css.unary type once we can */
// ** POSITION ******************#
type Css.position =
{ absolute }
/ { relative }
/ { fixed }
/ { static } /* default */
// ** CURSOR ********************#
type Css.cursor_resize =
{ n }
/ { s }
/ { e }
/ { w }
/ { ne }
/ { nw }
/ { se }
/ { sw }
type Css.default_cursor =
{ pointer }
/ { auto } /* default */
/ { default }
/ { crosshair }
/ { progress }
/ { move }
/ { text }
/ { resize: Css.cursor_resize }
/ { help }
/ { wait }
type Css.cursor =
{ icons: list(url)
default: Css.default_cursor
}
// ** FONT **********************#
type Css.font =
{ size: Css.size
line_height: Css.size_or_normal
family: Css.font_family
decoration: list(Css.decoration)
}
/*
you can't specify exact fonts, just stacks of fonts
see get_font_family definition to see the content of each family
*/
type Css.font_family =
{ TimesNewRoman }
/ { Georgia }
/ { Garamond }
/ { Helvetica }
/ { Verdana }
/ { Trebuchet }
/ { HeavyImpact }
/ { Monospace }
type Css.font_variant =
{ normal }
/ { inherit }
/ { small_caps }
// ** DECORATION ****************#
type Css.decoration =
{ italic }
/ { bold }
/ { underline }
/ { overline }
/ { line_through }
/ { small_caps }
/ { normal }
// ** DISPLAY ********************
type Css.display =
{ block }
/ { inline }
/ { inline_block }
/ { css_none } /* not "none" to avoid conflict with the option type. Would be nicer to embed this sum into the Css.unary type once we can */
// ** OVERFLOW ******************#
type Css.overflow =
{ hidden }
/ { visible }
/ { scroll }
/ { auto }
// ** SIZE **********************#
@opacapi
type Css.size =
{ cm : float }
/ { em: float }
/ { ex: float }
/ { inch : float}
/ { mm: float }
/ { pc : float }
/ { percent: float }
/ { pt : float }
/ { px: int }
@opacapi
type Css.size_or_normal =
{ normal }
/ { size : Css.size }
@opacapi
type Css.size_or_none =
{ none }
/ { size : Css.size }
// ** BORDER_SIZE ****************
type Css.block_size = // none on every field is not supposed to happen, but even if it happens, to_xhtml_style is going to ignore it
{ t: option(Css.size) l: option(Css.size) b: option(Css.size) r: option(Css.size) }
// ** BORDER_TYPE ****************
type Css.border =
tuple_2(border, Css.border_type)
type border =
{ all }
/ { left }
/ { right }
/ { top }
/ { bottom }
type Css.border_style_elt =
{ css_none } /* default */ /* not "none" to avoid conflict with the option type. Would be nicer to embed this sum into the Css.unary type once we can */
/ { hidden }
/ { dotted }
/ { dashed }
/ { solid }
/ { double }
/ { groove }
/ { ridge }
/ { inset }
/ { outset }
type Css.border_thickness =
{ thin }
/ { medium }
/ { thick }
/ { size: Css.size }
type Css.border_type =
{ style: option(Css.border_style_elt)
width: option(Css.border_thickness)
color: option(color) }
// ** BACKGROUND ****************#
@opacapi
type Css.background =
{ url: option(url)
position: option(Css.background_position)
repeat: option(Css.background_repeat)
color: option(color)
attached : option(void)
}
type Css.background_position =
{
x: Css.background_position_x
y: Css.background_position_y
}
type Css.background_repeat =
{ x }
/ { y }
/ { css_none } /* not "none" to avoid conflict with the option type. Would be nicer to embed this sum into the Css.unary type once we can */
/ { both } /* default */
type Css.background_position_y =
{ center }
/ { top } /* default */
/ { bottom }
/ { size: Css.size }
type Css.background_position_x =
{ center }
/ { left } /* default */
/ { right }
/ { size: Css.size }
/**
* The selector type describes the criterion that must be respected for some
* style to be applied to an xhtml element.
*/
type Css.selector = list(Css.selector_path) /*a, p*/
type Css.selector_path = list(Css.selector_conjunction) /*a p*/
type Css.selector_conjunction = list(Css.selector_item) /* a:onclick.classA */
@opacapi
type Css.event = {hover} / {active} / {visited} / {link} / {first_child} / {focus} // todo: complete this list // ADAM says: I think now only lang is missing (which is a bit more tricky as it takes argument)
@opacapi
type Css.selector_item =
{ tag : string } /
{ id: string } /
{ class : string } /
{ event : Css.event}
/**
* An entry is described by, err... a list of disjunctions of conjunctions of items ?? (Louis)
*/
type Css.entry = list(list(list(Css.selector_item)))
type Css.properties = list(Css.unary)
// Bound from the opabsl
type css_properties = Css.properties
/**
* {1 Css_build interface}
*/
/**
* Constructors for typed css
*
* This module defines all constructors to build values of the main [Css.unary] type.
*/
Css_build =
{{
/**
* this two function should no be inside the module,
* but because of open module with local environ crash, they moved here
*/
sum_option(o1,o2) =
match (o1,o2) with
| (_,{none}) -> o1
| _ -> o2
size_or_normal_of_option_size(v) =
match v with
| { none } -> { normal }
| { ~some } -> { size = some }
/**** background *****/
/*
-- background([background_repeat,background_image(string)])
corresponds to
-- background: repeat url(string)
if you define a value several times, only the last one is kept
-- background([background_color(Color.blue),background_color(Color.red)])
is equivalent to
-- background([background_color(Color.red)])
(which means that
-- background: blue red
will be understood as
-- background: red
*/
no_background = { url = none position = none repeat = none color = none attached = none } : Css.background
sum_background({url=url1 position=position1 repeat=repeat1 color=color1 attached=attached1},
{url=url2 position=position2 repeat=repeat2 color=color2 attached=attached2}) =
{ url = sum_option(url1,url2)
position = sum_option(position1,position2)
repeat = sum_option(repeat1,repeat2)
color = sum_option(color1,color2)
attached = sum_option(attached1,attached2)
}
rev_sum_background(b1,b2) = sum_background(b2,b1)
background(l:list(Css.background)) = { background = List.foldl(rev_sum_background,l,no_background)} : Css.unary
background_image(url) = { no_background with url = some(url)} : Css.background
background_position(x,y) = { no_background with position = some({~x ~y})} : Css.background
background_no_repeat = { no_background with repeat = some({css_none}) } : Css.background
background_repeat = { no_background with repeat = some({both}) } : Css.background
background_repeat_x = { no_background with repeat = some({x}) } : Css.background
background_repeat_y = { no_background with repeat = some({y}) } : Css.background
background_color(color) = { no_background with color = some(color)} : Css.background
background_attached = { no_background with attached = some(void)} : Css.background
/***** border ******/
/*
-- border-left: thick
corresponds to
-- border_left(border_thick)
-- border-left: thick dotted
corresponds to
-- border_left(border_type([border_thick,border_dotted]))
*/
rev_sum_border({style=style1 width=width1 color=color1},{style=style2 width=width2 color=color2}) =
{ style = sum_option(style2,style1)
width = sum_option(width2,width1)
color = sum_option(color2,color1)
} : Css.border_type
no_border_type = { style = none width = none color = none } : Css.border_type
border_style(v) = { style = some(v) width = none color = none } : Css.border_type
border_width(v) = { style = none width = some(v) color = none } : Css.border_type
border_color(v) = { style = none width = none color = some(v) } : Css.border_type
border_radius(v) = { border_radius = v } : Css.unary
border_left(v) = { border = ({left}, v)} : Css.unary
border_right(v) = { border = ({right}, v)} : Css.unary
border_top(v) = { border = ({top}, v)} : Css.unary
border_bottom(v) = { border = ({bottom}, v)} : Css.unary
border_all(v) = { border = ({all}, v)} : Css.unary
border_type(l) = List.foldl(rev_sum_border,l,no_border_type) : Css.border_type
border_thin = border_width({thin})
border_medium = border_width({medium})
border_thick = border_width({thick})
border_size(size) = border_width({~size})
border_none = border_style({css_none})
border_hidden = border_style({hidden})
border_dotted = border_style({dotted})
border_dashed = border_style({dashed})
border_solid = border_style({solid})
border_double = border_style({double})
border_groove = border_style({groove})
border_ridge = border_style({ridge})
border_inset = border_style({inset})
border_outset = border_style({outset})
/*** border-collapse ****/
border_collapse(v) = { border_collapse = v } : Css.unary
/*** border-spacing ****/
border_spacing(v) = { border_spacing = v } : Css.unary
/**** bottom ****/
bottom(s) = { bottom = s } : Css.unary
/**** color ****/
color(color) = { color= color }
/**** cursor *****/
/*
-- cursor: image1, image2, move
translates to
-- cursor({icons=[image1,image2] default=cursor_move}
*/
coerce_default_cursor(v) = v : Css.default_cursor
cursor_pointer = coerce_default_cursor({pointer})
cursor_auto = coerce_default_cursor({auto})
cursor_default = coerce_default_cursor({default})
cursor_crosshair = coerce_default_cursor({crosshair})
cursor_progress = coerce_default_cursor({progress})
cursor_move = coerce_default_cursor({move})
cursor_text = coerce_default_cursor({text})
cursor_resize_n = coerce_default_cursor({resize = {n}})
cursor_resize_s = coerce_default_cursor({resize = {s}})
cursor_resize_e = coerce_default_cursor({resize = {e}})
cursor_resize_w = coerce_default_cursor({resize = {w}})
cursor_resize_ne = coerce_default_cursor({resize = {ne}})
cursor_resize_nw = coerce_default_cursor({resize = {nw}})
cursor_resize_se = coerce_default_cursor({resize = {se}})
cursor_resize_sw = coerce_default_cursor({resize = {sw}})
cursor_help = coerce_default_cursor({help})
cursor_wait = coerce_default_cursor({wait})
cursor(v) = { cursor = v } : Css.unary
cursor2(v1,v2) = cursor({icons=v1 default=v2})
/**** direction ****/
direction(v) = { direction = v } : Css.unary
left_to_right = direction({ left_to_right })
right_to_left = direction({ right_to_left })
/**** display ***/
display(v) = { display = v } : Css.unary
display_block = display({block})
display_inline = display({inline})
display_inline_block = display({inline_block})
display_none = display({css_none})
/*** float ****/
float(v) = { float = v } : Css.unary
float_left = float({left})
float_right = float({right})
float_none = float({css_none})
/**** font_decoration ****/
font_decorations(v) = { font_decoration = v } : Css.unary
font_decoration(v) = font_decorations([v])
font_variant(v) = { font_variant = v } : Css.unary
italic = font_decoration({ italic })
bold = font_decoration({ bold })
underline = font_decoration({ underline })
overline = font_decoration({ overline })
line_through = font_decoration({ line_through })
small_caps = font_decoration({ small_caps })
normal = font_decoration({ normal })
/**** font_family ****/
font_family(v) = { font_family = v } : Css.unary
font_TimesNewRoman = font_family({TimesNewRoman})
font_Georgia = font_family({Georgia})
font_Garamond = font_family({Garamond})
font_Helvetica = font_family({Helvetica})
font_Verdana = font_family({Verdana})
font_Trebuchet = font_family({Trebuchet})
font_HeavyImpact = font_family({HeavyImpact})
font_Monospace = font_family({Monospace})
/**** font_size ****/
font_size(s) = { font_size = s } : Css.unary
/**** font ****/
font(v) = { font = v } : Css.unary
font2(decoration,size,lineo,family) =
font({ size = size;
line_height = size_or_normal_of_option_size(lineo);
family = family;
decoration = decoration
})
/**** height ****/
height(size) = { height = size} : Css.unary
max_height(size) = { max_height = size } : Css.unary
min_height(size) = { min_height = size } : Css.unary
/**** left ****/
left(size) = { left = size} : Css.unary
/*** letter_spacing ****/
letter_spacing(size_normal) =
{ letter_spacing = size_normal } : Css.unary
/**** line-height ****/
line_height(size) = { line_height = size} : Css.unary
/**** list_style ****/
/*
-- list-style: square outside
-- list_style({style=square position={outside}})
shortcuts:
-- list-style: square
-- list_square
-- list-style: inside
-- list_inside
*/
list_style(v) = { list_style = v } : Css.unary
list_style2(pos,style) = list_style({ style=style style_position=pos })
list_style_position(v) = list_style2(some(v),none)
list_style_style(style)= list_style2(none,some(style))
list_style_inside = list_style_position({inside})
list_style_outside = list_style_position({outside})
no_list_style =
{ style_position = none;
style = none
} : Css.list_style
list_image(url) = list_style_style({image = url})
list_disc = list_style_style({disc})
list_square = list_style_style({square})
list_decimal = list_style_style({decimal = {not_leading}})
list_decimal_leading = list_style_style({decimal = {leading}})
list_lower_roman = list_style_style({roman = {lower_case}})
list_upper_roman = list_style_style({roman = {upper_case}})
list_lower_latin = list_style_style({latin = {lower_case}})
list_upper_latin = list_style_style({latin = {upper_case}})
list_upper_alpha = list_upper_latin
list_lower_alpha = list_lower_latin
list_greek = list_style_style({greek})
list_lower_greek = list_greek
/**** margin ****/
margin(t,l,b,r) = { margin = {~t ~l ~b ~r} } : Css.unary
margin_all(s) = margin(some(s),some(s),some(s),some(s))
margin_top(s) = margin(some(s),none,none,none)
margin_bottom(s) = margin(none,none,some(s),none)
margin_left(s) = margin(none,some(s),none,none)
margin_right(s) = margin(none,none,none,some(s))
/**** opacity ****/
opacity(f) = { opacity = f }
/**** overflow ****/
overflow(v) = { overflow = v } : Css.unary
overflow_hidden = overflow({hidden})
overflow_visible = overflow({visible})
overflow_scroll = overflow({scroll})
overflow_auto = overflow({auto})
/**** padding ****/
padding(t,l,b,r) = { padding = {~t ~l ~b ~r} } : Css.unary
padding_all(s) = padding(some(s),some(s),some(s),some(s))
padding_top(s) = padding(some(s),none,none,none)
padding_bottom(s) = padding(none,none,some(s),none)
padding_left(s) = padding(none,some(s),none,none)
padding_right(s) = padding(none,none,none,some(s))
/**** position ****/
position(v) = { position = v } : Css.unary
position_fixed = position({fixed})
position_static = position({static})
position_absolute = position({absolute})
position_relative = position({relative})
/**** right ****/
right(size) = { right = size } : Css.unary
/*** table-layout ****/
table_layout(v) = { table_layout = v } : Css.unary
/*** text_align ****/
text_align(v) = { text_align = v } : Css.unary
align_left = text_align({left})
align_right = text_align({right})
align_center = text_align({center})
align_justify = text_align({justify})
/**** top ****/
top(s) = { top = s } : Css.unary
/**** whitespace ***/
vertical_align(v) = { vertical_align = v } : Css.unary
vertical_align_middle = vertical_align({middle})
vertical_align_baseline = vertical_align({baseline})
/**** visibility ****/
visibility(v) = { visibility = v} : Css.unary
visible = visibility({ visible })
hidden = visibility({ hidden })
/**** width ****/
width(s) = { width = s } : Css.unary
max_width(size) = { max_width = size } : Css.unary
min_width(size) = { min_width = size } : Css.unary
/**** whitespace ***/
white_space(v) = { white_space = v} : Css.unary
white_space_pre = white_space({pre})
white_space_normal = white_space({normal})
white_space_nowrap = white_space( {nowrap})
/*** index ***/
z_index(o) = { z_index = o } : Css.unary
z_index_n(n) = z_index(some(n))
z_index_auto = z_index(none)
}}
/**
* {1 Functions exported to the global namespace}
*/
/* ---------------- < utilities for CSS > --------------- */
map_css_size(f) =
| { ~cm } -> {cm = f(cm)}
| { ~em } -> {em = f(em)}
| { ~ex } -> {ex = f(ex)}
| { ~inch } -> {inch = f(inch)}
| { ~mm } -> {mm = f(mm)}
| { ~pc } -> {pc = f(pc)}
| { ~percent } -> {percent = f(percent)}
| { ~pt } -> {pt = f(pt)}
| { ~px } -> {px = Float.to_int(f(Int.to_float(px)))}
/* --------------------- < CSS > -------------------- */
type Css.prop_name = string
@opacapi
type Css.percentage = int
@opacapi
type Css.length =
{ nounitF : float } /
{ nounitI : float } / // but this is an int ;-) !
{ em : float } /
{ ex : float } /
{ px : float } /
{ inch : float } /
{ cm : float } /
{ mm : float } /
{ pt : float } /
{ pc : float }
px(x) = {length={px=x}:Css.length}:Css.prop_value_item
length_to_css_string(l) =
f(x:float) = "{x}"
i(x:float) = "{int_of_float(x)}";
match l : Css.length with
| { ex=x } -> "{i(x)}ex"
| { em=x } -> "{f(x)}em"
| { cm=x } -> "{f(x)}cm"
| { mm=x } -> "{i(x)}mm"
| { px=x } -> "{i(x)}px"
| { pt=x } -> "{i(x)}pt"
| { pc=x } -> "{i(x)}pc"
| { inch=x } ->"{f(x)}inch"
| { nounitF=x } -> "{f(x)}"
| { nounitI=x } -> "{i(x)}"
type Css.url = string
@opacapi
type Css.prop_value_item =
{ property : string } /
{ percentage : Css.percentage } /
{ length : Css.length } /
{ color : color } /
{ url : url }
type Css.prop_value = list(Css.prop_value_item)
type Css.props = map(Css.prop_name, Css.prop_value)
type Css.type = map(Css.selector, Css.props)
type Css.def = list(Css.type)
@abstract type Css.order = void
type Css.declaration = list(ordered_map(Css.entry, Css.props, Css.order))
empty_css = [] : Css.declaration
css_map_merge(submerge, map2, map1) =
Css_private.Entry_map.fold(
(k2, v2, map1 -> match Css_private.Entry_map.get(k2, map1) with
|{~some} -> Css_private.Entry_map.add(k2, submerge(some, v2), map1)
|{none} -> Css_private.Entry_map.add(k2, v2, map1)
), map2, map1)
/*
construct_map_css_def(css_def) = List.map( construct_map_css_type , css_def )
construct_map_css_type(
*/
generate_css_def(css_def:Css.declaration) =
css_type =
match css_def
| [] -> Css_private.Entry_map.empty
| [hd | tl] -> List.foldl(css_map_merge(css_props_merge,_,_), tl , hd)
;
generate_css_type("", css_type)
generate_css_type(acc, css_type) =
Css_private.Entry_map.fold(generate_paths_props, css_type, acc)
generate_paths_props(paths, props, acc:string) =
"{acc}{generate_paths(paths)} \{{ generate_props(props, "") }\}\n"
generate_paths(paths) = String.concat(",", List.map(generate_path, paths))
generate_path(path) = String.concat(" ", List.map(generate_selector, path))
generate_selector(sel)= String.concat("", List.map(generate_selector_item, sel))
generate_selector_item(sel) =
match sel : Css.selector_item with
| {~tag} -> "{tag}"
| {~id} -> "#{id}"
| {class=c} -> ".{c}"
| {event={hover}} -> ":hover"
| {event={active}} -> ":active"
| {event={visited}} -> ":visited"
| {event={link}} -> ":link"
| {event={first_child}} -> ":first-child"
| {event={focus}} -> ":focus"
generate_props(props:Css.props, acc:string) =
add_prop(prop_name, prop_value, acc)="{acc}{prop_name} : {generate_prop_value(prop_value)};"
Map.fold(add_prop, props, acc)
generate_prop_value(prop_value) =
List.foldl( (it,acc-> acc^generate_prop_value_item(it)^" ") , prop_value, "")
generate_prop_value_item(item) =
match item : Css.prop_value_item with
| {~property} -> property
| {~percentage} -> "{percentage}%"
| {~length} -> length_to_css_string(length)
| {~color} -> Color.color_to_string(color)
| {~url} -> "url('{Url.encode(url)}')"
| _ -> error("BAD VALUE_ITEM")
css_props_merge(m1, m2) = Map.union(m1, m2)
Jump to Line
Something went wrong with that request. Please try again.