mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-20 03:43:51 +00:00
Code Issues Projects Releases Wiki Activity
Files
4b052d46dd8b0dd5b9ca449bde12cd12fae76fc2
mercury/deep_profiler/html_format.m
Zoltan Somogyi 9095985aa8 Fix more warnings from --warn-inconsistent-pred-order-clauses. 
deep_profiler/*.m:
    Fix inconsistencies between (a) the order in which functions and predicates
    are declared, and (b) the order in which they are defined.

    In most modules, either the order of the declarations or the order
    of the definitions made sense, and I changed the other to match.
    In some modules, neither made sense, so I changed *both* to an order
    that *does* make sense (i.e. it has related predicates together).

    In query.m, put the various commands in the same sensible order
    as the code processing them.

    In html_format.m, merge two exported functions together, since
    they can't be used separately.

    In some places, put dividers between groups of related
    functions/predicates, to make the groups themselves more visible.

    In some places, fix comments or programming style.

deep_profiler/DEEP_FLAGS.in:
    Since all the modules in this directory are now free from any warnings
    generated by --warn-inconsistent-pred-order-clauses, specify that option
    by default in this directory to keep it that way.
2017-04-30 15:48:13 +10:00

1063 lines
38 KiB
Mathematica
Raw Blame History

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2001-2002, 2004-2011 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%---------------------------------------------------------------------------%
%
% File: html_format.m.
% Author: zs, pbone.
%
% This module contains code that sets the format of the HTML tables
% we generate for individual queries.
%
% This module appends many strings. Since string.append takes time that is
% linear over the length of both input strings, building a long string
% from many short strings would take quadratic time. This is why we represent
% HTML as a cord of strings instead. This cord is then converted to a list of
% strings and then a single string just before being given to the browser.
%
%---------------------------------------------------------------------------%
:- module html_format.
:- interface.
:- import_module profile.
:- import_module query.
:- import_module display.
%---------------------------------------------------------------------------%
% Construct a complete HTML page from the given display structure.
%
% The first parameter is used to gather extra information from the deep
% profile, for example the name of the Deep.data file to build the URLs
% from.
%
:- func htmlize_display(deep, preferences, display) = string.
%---------------------------------------------------------------------------%
% Convert any special characters in a string into appropriate HTML
% escapes.
%
:- func escape_html_string(string) = string.
:- func escape_html_attr_string(attr_string) = string.
% Like escape_html_string, but additionally inserts zero-width space
% characters to suggest where long strings can be broken over multiple
% lines.
%
:- func escape_break_html_string(string) = string.
:- func escape_break_html_attr_string(attr_string) = string.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
:- import_module char.
:- import_module cord.
:- import_module int.
:- import_module list.
:- import_module map.
:- import_module maybe.
:- import_module pair.
:- import_module require.
:- import_module set.
:- import_module string.
:- import_module measurement_units.
%---------------------------------------------------------------------------%
:- type html == cord(string).
%---------------------------------------------------------------------------%
htmlize_display(Deep, Prefs, Display) = HTMLStr :-
Display = display(MaybeTitle, Items),
MainTitle = str_to_html("Mercury Deep Profile for ") ++
str_to_html(Deep ^ data_file_name),
(
MaybeTitle = no,
HeadTitle = MainTitle,
HeadingHTML = empty_html
;
MaybeTitle = yes(Title),
TitleHTML = str_to_html(Title),
HeadTitle = MainTitle ++ str_to_html(" - ") ++ TitleHTML,
HeadingHTML = wrap_tags("<h3>", "</h3>\n", TitleHTML)
),
HeadTitleHTML = wrap_tags("<title>", "</title>\n", HeadTitle),
FormatInfo = init_format_info(Deep, Prefs),
StyleControlMap0 = default_style_control_map,
map_join_html(item_to_html("<div>\n", "</div>\n", FormatInfo),
StyleControlMap0, StyleControlMap, Items, ItemsHTML),
StyleHTML = css_style_html(StyleControlMap),
HTML = doc_type_html ++
wrap_tags("<html>\n", "</html>\n",
wrap_tags("<head>\n", "</head>\n", HeadTitleHTML ++ StyleHTML) ++
wrap_tags("<body>\n", "</body>\n", HeadingHTML ++ ItemsHTML)
),
HTMLStr = string.append_list(cord.list(HTML)).
:- func doc_type_html = html.
doc_type_html =
str_to_html(
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\"\n" ++
"\"http://www.w3.org/TR/html4/strict.dtd\">\n").
%---------------------%
:- func css_style_html(style_control_map) = html.
css_style_html(StyleControlMap) = HTML :-
% XXX This ignores colour_column_groups. We should respect it,
% and process it either here, or when converting table columns to HTML.
map.to_assoc_list(StyleControlMap, StyleControls),
ControlHTMLs = list.map(style_control_to_html, StyleControls),
ControlsHTML = append_htmls(ControlHTMLs),
HTML = wrap_tags("<style type=\"text/css\">\n", "</style>\n",
ControlsHTML).
:- func style_control_to_html(pair(style_control, style_element_map)) = html.
style_control_to_html(Control - StyleElementMap) = HTML :-
Control = style_control(ControlName),
StyleElements = map.to_assoc_list(StyleElementMap),
ElementHTMLs = list.map(style_element_to_html, StyleElements),
ElementsHTML = append_htmls(ElementHTMLs),
StartFragmentHTML =
str_to_html(string.format("\t%s\n\t{\n", [s(ControlName)])),
EndFragmentHTML = str_to_html("\t}\n"),
HTML = StartFragmentHTML ++ ElementsHTML ++ EndFragmentHTML.
:- func style_element_to_html(pair(style_element, string)) = html.
style_element_to_html(style_element(ElementName) - Value) =
str_to_html(string.format("\t\t%s: %s;\n", [s(ElementName), s(Value)])).
%---------------------%
% Convert a display item into a HTML snippet.
%
:- pred item_to_html(string::in, string::in, format_info::in,
style_control_map::in, style_control_map::out,
display_item::in, html::out) is det.
item_to_html(StartTag, EndTag, FormatInfo, !StyleControlMap, Item, HTML) :-
(
Item = display_heading(Message),
HTML = wrap_tags(StartTag, EndTag,
wrap_tags("<h3>", "</h3>\n", str_to_html(Message)))
;
Item = display_text(Message),
HTML = wrap_tags(StartTag, EndTag, str_to_html(Message))
;
Item = display_paragraph_break,
HTML = str_to_html("<p>\n")
;
Item = display_link(DeepLink),
HTML = wrap_tags(StartTag, EndTag,
link_to_html(FormatInfo, DeepLink))
;
Item = display_pseudo_link(PseudoLink),
HTML = wrap_tags(StartTag, EndTag,
pseudo_link_to_html(FormatInfo, PseudoLink))
;
Item = display_table(Table),
table_to_html(FormatInfo, !StyleControlMap, Table, TableHTML),
HTML = wrap_tags(StartTag, EndTag, TableHTML)
;
Item = display_list(Class, MaybeTitle, Items),
DeveloperMode = FormatInfo ^ fi_pref_developer,
( if
% If developer only items are invisible and all the items in the
% list are developer items, then don't display the list at all.
DeveloperMode = developer_options_invisible,
not (
some [ListItem] (
member(ListItem, Items),
not ListItem = display_developer(_)
)
)
then
HTML = empty
else
list_to_html(FormatInfo, !StyleControlMap, Class, MaybeTitle,
Items, TableHTML),
HTML = wrap_tags(StartTag, EndTag, TableHTML)
)
;
Item = display_verbatim(Text),
HTML = wrap_tags(StartTag, EndTag,
wrap_tags("<pre>", "</pre>", str_to_html(Text)))
;
Item = display_developer(SubItem),
DeveloperMode = FormatInfo ^ fi_pref_developer,
(
DeveloperMode = developer_options_visible,
item_to_html(StartTag, EndTag, FormatInfo, !StyleControlMap,
SubItem, HTML)
;
DeveloperMode = developer_options_invisible,
HTML = empty
)
).
%---------------------------------------------------------------------------%
%
% Table htmlization.
%
% The number of rows to be used for a table header.
%
:- type table_header_rows
---> one_header_row
; two_header_rows.
% A mapping of column numbers to classes.
%
:- type column_class_map == map(int, string).
%---------------------------------------------------------------------------%
% Create a HTML table entity from the given table description.
%
:- pred table_to_html(format_info::in,
style_control_map::in, style_control_map::out,
table::in, html::out) is det.
table_to_html(FormatInfo, !StyleControlMap, Table, HTML) :-
Table = table(Class, NumColumns, MaybeHeader, BodyRows),
ClassStr = table_class_to_string(FormatInfo, Class),
TableStartTag = "<table class=\"" ++ ClassStr ++ "\">\n",
TableEndTag = "</table>\n",
% Build a header row.
(
MaybeHeader = yes(table_header(THCells)),
list.foldl6(table_header_num_rows_and_classmap(FormatInfo), THCells,
one_header_row, THNumRows, 0, _, map.init, ClassMap,
0, _, set.init, _, !StyleControlMap),
MaybeClassMap = yes(ClassMap),
map_join_html(table_header_group_to_html_row_1(FormatInfo, THNumRows),
!StyleControlMap, THCells, InnerHeaderRowOneHTML),
HeaderRowOneHTML =
wrap_tags("<tr>\n", "</tr>\n", InnerHeaderRowOneHTML),
(
THNumRows = one_header_row,
HeaderRowTwoHTML = empty_html
;
THNumRows = two_header_rows,
map_join_html(table_header_group_to_html_row_2(FormatInfo),
!StyleControlMap, THCells, InnerHeaderRowTwoHTML),
HeaderRowTwoHTML =
wrap_tags("<tr>\n", "</tr>\n", InnerHeaderRowTwoHTML)
),
InnerHeaderRowThree =
string.format("<td colspan=\"%d\"/>", [i(NumColumns)]),
HeaderRowThreeHTML =
wrap_tags("<tr>", "</tr>", str_to_html(InnerHeaderRowThree)),
HeaderHTML = HeaderRowOneHTML ++ HeaderRowTwoHTML ++ HeaderRowThreeHTML
;
MaybeHeader = no,
MaybeClassMap = no,
HeaderHTML = empty_html
),
% Build the table rows.
map_join_html(table_row_to_html(FormatInfo, MaybeClassMap, NumColumns),
!StyleControlMap, BodyRows, BodyRowsHTML),
% Construct the table.
WrappedHeaderHTML = wrap_tags("<thead>\n", "</thead>\n", HeaderHTML),
WrappedBodyHTML = wrap_tags("<tbody>\n", "</tbody>\n", BodyRowsHTML),
HTML = wrap_tags(TableStartTag, TableEndTag,
WrappedHeaderHTML ++ WrappedBodyHTML).
%---------------------------------------------------------------------------%
% Return the HTML entity for a table header cell.
%
:- pred table_header_group_to_html_row_1(format_info::in,
table_header_rows::in, style_control_map::in, style_control_map::out,
table_header_group::in, html::out) is det.
table_header_group_to_html_row_1(FormatInfo, HeaderNumRows, !StyleControlMap,
HeaderGroup, HTML) :-
HeaderGroup = table_header_group(Titles, ColumnClass, _SetStyle),
(
Titles = table_header_group_single(Title),
(
HeaderNumRows = one_header_row,
RowSpan = "1"
;
HeaderNumRows = two_header_rows,
RowSpan = "2"
),
ColumnSpan = "1",
ContentsHTML = table_data_to_html(FormatInfo, Title)
;
Titles = table_header_group_multi(MainTitle, SubTitleCells),
RowSpan = "1",
list.length(SubTitleCells, NumSubTitleCells),
ColumnSpan = string.int_to_string(NumSubTitleCells),
ContentsHTML = str_to_html(MainTitle)
),
ColumnClassStr = table_column_class_to_string(ColumnClass),
StartTag = string.format(
"<th rowspan=\"%s\" colspan=\"%s\" class=\"%s\">",
[s(RowSpan), s(ColumnSpan), s(ColumnClassStr)]),
EndTag = "</th>\n",
HTML = wrap_tags(StartTag, EndTag, ContentsHTML).
%---------------------------------------------------------------------------%
:- pred table_header_group_to_html_row_2(format_info::in,
style_control_map::in, style_control_map::out,
table_header_group::in, html::out) is det.
table_header_group_to_html_row_2(FormatInfo, !StyleControlMap,
HeaderGroup, HTML) :-
HeaderGroup = table_header_group(Titles, ColumnClass, _SetStyle),
(
Titles = table_header_group_single(_),
HTML = empty_html
;
Titles = table_header_group_multi(_, SubTitleCells),
map_join_html(table_data_to_th_html(FormatInfo, ColumnClass),
!StyleControlMap, SubTitleCells, HTML)
).
%---------------------------------------------------------------------------%
:- pred table_data_to_th_html(format_info::in, table_column_class::in,
style_control_map::in, style_control_map::out,
table_data::in, html::out) is det.
table_data_to_th_html(FormatInfo, ColumnClass, !StyleControlMap,
TableData, HTML) :-
ColumnClassStr = table_column_class_to_string(ColumnClass),
TableDataHTML = table_data_to_html(FormatInfo, TableData),
StartTag = string.format("<th class=\"%s\">", [s(ColumnClassStr)]),
EndTag = "</th>\n",
HTML = wrap_tags(StartTag, EndTag, TableDataHTML).
%---------------------------------------------------------------------------%
% Determine how many rows the table header requires, and set up a map
% from column numbers to classes. Update the style control map for
% table header groups that specify table_set_style.
%
% This should be used with list.foldl6.
%
:- pred table_header_num_rows_and_classmap(format_info::in,
table_header_group::in, table_header_rows::in, table_header_rows::out,
int::in, int::out, column_class_map::in, column_class_map::out,
int::in, int::out, set(string)::in, set(string)::out,
style_control_map::in, style_control_map::out) is det.
table_header_num_rows_and_classmap(FormatInfo, HeaderGroup, !NumRows,
!ColumnNumber, !ClassMap, !HeaderGroupNumber, !ColouredClassStrs,
!StyleControlMap) :-
HeaderGroup = table_header_group(ColumnTitles, ColumnClass, MaybeColour),
ColumnClassStr = table_column_class_to_string(ColumnClass),
(
ColumnTitles = table_header_group_single(_),
NumSubCols = 1,
map.det_insert(!.ColumnNumber, ColumnClassStr, !ClassMap)
;
ColumnTitles = table_header_group_multi(_, SubTitles),
list.length(SubTitles, NumSubCols),
!:NumRows = two_header_rows,
% fold_up is inclusive of the higher number.
int.fold_up(insert_column_into_classmap(ColumnClassStr),
!.ColumnNumber, !.ColumnNumber + NumSubCols - 1, !ClassMap)
),
!:ColumnNumber = !.ColumnNumber + NumSubCols,
(
MaybeColour = column_do_not_colour,
Colour = do_not_colour_column_groups
;
MaybeColour = column_colour,
Colour = colour_column_groups
;
MaybeColour = column_colour_if_pref,
Colour = FormatInfo ^ fi_pref_colour_scheme
),
(
Colour = do_not_colour_column_groups
;
Colour = colour_column_groups,
update_style_control_map(ColumnClassStr, !HeaderGroupNumber,
!ColouredClassStrs, !StyleControlMap)
).
:- pred insert_column_into_classmap(string::in, int::in,
column_class_map::in, column_class_map::out) is det.
insert_column_into_classmap(Value, Key, !Map) :-
map.det_insert(Key, Value, !Map).
:- pred update_style_control_map(string::in, int::in, int::out,
set(string)::in, set(string)::out,
style_control_map::in, style_control_map::out) is det.
update_style_control_map(ColumnClassStr, !HeaderGroupNumber,
!ColouredClassStrs, !StyleControlMap) :-
StyleControl = style_control("td." ++ ColumnClassStr),
StyleElement = style_element("background"),
( if !.HeaderGroupNumber /\ 1 = 0 then
Colour = "LightGrey"
else
Colour = "White"
),
( if set.member(ColumnClassStr, !.ColouredClassStrs) then
unexpected($module, $pred, "repeated table_column_class")
else
set.insert(ColumnClassStr, !ColouredClassStrs)
),
( if map.search(!.StyleControlMap, StyleControl, StyleElementMap0) then
map.set(StyleElement, Colour, StyleElementMap0, StyleElementMap),
map.det_update(StyleControl, StyleElementMap, !StyleControlMap)
else
StyleElementMap = map.singleton(StyleElement, Colour),
map.det_insert(StyleControl, StyleElementMap, !StyleControlMap)
),
!:HeaderGroupNumber = !.HeaderGroupNumber + 1.
%---------------------------------------------------------------------------%
% Build a row of a HTML table from the table_row type.
%
:- pred table_row_to_html(format_info::in, maybe(column_class_map)::in,
int::in, style_control_map::in, style_control_map::out,
table_row::in, html::out) is det.
table_row_to_html(FormatInfo, MaybeColClassMap, NumColumns, !StyleControlMap,
TableRow, HTML) :-
(
TableRow = table_section_header(Contents),
ContentsHTML = table_data_to_html(FormatInfo, Contents),
StartTag = string.format("<tr><td colspan=\"%d\">", [i(NumColumns)]),
EndTag = "</td></tr>\n",
HTML = wrap_tags(StartTag, EndTag, ContentsHTML)
;
TableRow = table_separator_row,
Str = string.format("<tr><td colspan=\"%d\"></td></tr>\n",
[i(NumColumns)]),
HTML = str_to_html(Str)
;
TableRow = table_row(Cells),
map_join_html_count(table_cell_to_html(FormatInfo, MaybeColClassMap),
!StyleControlMap, 0, Cells, InnerHTML),
HTML = wrap_tags("<tr>\n", "</tr>\n", InnerHTML)
;
TableRow = table_developer_row(RealTableRow),
Developer = FormatInfo ^ fi_pref_developer,
(
Developer = developer_options_visible,
table_row_to_html(FormatInfo, MaybeColClassMap, NumColumns,
!StyleControlMap, RealTableRow, HTML)
;
Developer = developer_options_invisible,
HTML = cord.empty
)
).
%---------------------------------------------------------------------------%
:- pred table_cell_to_html(format_info::in, maybe(column_class_map)::in,
style_control_map::in, style_control_map::out,
int::in, int::out, table_cell::in, html::out) is det.
table_cell_to_html(FormatInfo, MaybeClassMap, !StyleControlMap, !ColumnNum,
Cell, HTML) :-
(
Cell = table_empty_cell,
!:ColumnNum = !.ColumnNum + 1,
HTML = str_to_html("<td/>")
;
(
Cell = table_cell(CellData),
Span = 1
;
Cell = table_multi_cell(CellData, Span)
),
(
MaybeClassMap = yes(ClassMap),
( if map.search(ClassMap, !.ColumnNum, ColumnClassStrPrime) then
ColumnClassStr = ColumnClassStrPrime
else
Msg = string.format(
"Class map had no class for col %d, check table structure",
[i(!.ColumnNum)]),
unexpected($module, $pred, Msg)
)
;
MaybeClassMap = no,
( if table_data_class(CellData, ColumnClassPrime) then
ColumnClass = ColumnClassPrime
else
ColumnClass = default_table_column_class
),
ColumnClassStr = table_column_class_to_string(ColumnClass)
),
CellHTML = table_data_to_html(FormatInfo, CellData),
( if Span = 1 then
SpanStr = ""
else
SpanStr = string.format("colspan=%d ", [i(Span)])
),
!:ColumnNum = !.ColumnNum + Span,
StartTag = string.format("<td %sclass=\"%s\">",
[s(SpanStr), s(ColumnClassStr)]),
EndTag = "</td>\n",
HTML = wrap_tags(StartTag, EndTag, CellHTML)
).
%---------------------------------------------------------------------------%
:- func table_data_to_html(format_info, table_data) = html.
table_data_to_html(_, td_f(Float)) =
str_to_html(two_decimal_fraction(Float)).
table_data_to_html(_, td_i(Int)) =
str_to_html(commas(Int)).
table_data_to_html(FormatInfo, td_l(Link)) =
link_to_html(FormatInfo, Link).
table_data_to_html(_, td_m(Mem, Units, Decimals)) =
str_to_html(format_memory(Mem, Units, Decimals)).
table_data_to_html(_, td_p(Percent)) =
str_to_html(format_percent(Percent)).
table_data_to_html(_, td_s(String)) =
str_to_html(escape_break_html_string(String)).
table_data_to_html(_, td_as(AttrString)) =
str_to_html(escape_break_html_attr_string(AttrString)).
table_data_to_html(_, td_t(Time)) =
str_to_html(format_time(Time)).
% This predicate is used when a table class map couldn't be built from the
% header of the table (perhaps there was no header). It provides a class
% for some data that class is used, otherwise the default class is
% assumed.
%
:- pred table_data_class(table_data::in, table_column_class::out) is semidet.
table_data_class(td_f(_), table_column_class_number).
table_data_class(td_i(_), table_column_class_number).
table_data_class(td_m(_, _, _), table_column_class_number).
table_data_class(td_p(_), table_column_class_number).
table_data_class(td_t(_), table_column_class_number).
:- func default_table_column_class = table_column_class.
default_table_column_class = table_column_class_no_class.
:- func table_column_class_to_string(table_column_class) = string.
table_column_class_to_string(table_column_class_no_class) = "default".
table_column_class_to_string(table_column_class_allocations) = "allocations".
table_column_class_to_string(table_column_class_clique) = "clique".
table_column_class_to_string(table_column_class_callseqs) = "callseqs".
table_column_class_to_string(table_column_class_field_name) = "field_name".
table_column_class_to_string(table_column_class_memory) = "memory".
table_column_class_to_string(table_column_class_module_name) = "module_name".
table_column_class_to_string(table_column_class_number) = "number".
table_column_class_to_string(table_column_class_ordinal_rank) = "ordinal_rank".
table_column_class_to_string(table_column_class_port_counts) = "port_counts".
table_column_class_to_string(table_column_class_proc) = "proc".
table_column_class_to_string(table_column_class_source_context) =
"source_context".
table_column_class_to_string(table_column_class_ticks_and_times) =
"ticks_and_times".
:- func table_class_to_string(format_info, table_class) = string.
table_class_to_string(FormatInfo, Class) = ClassStr :-
(
Class = table_class_do_not_box,
ClassStr = "plain"
;
Class = table_class_box,
ClassStr = "boxed"
;
Class = table_class_box_if_pref,
BoxPrefs = FormatInfo ^ fi_pref_box,
(
BoxPrefs = do_not_box_tables,
ClassStr = "plain"
;
BoxPrefs = box_tables,
ClassStr = "boxed"
)
).
%---------------------------------------------------------------------------%
% A style element is a variable you can set for a given control.
% Examples include "text-align" and "background".
%
:- type style_element
---> style_element(string).
% Maps a style element to its value.
%
:- type style_element_map == map(style_element, string).
% A style control is a category whose properties can be set independently.
% Examples include "td.allocations and "td.callseqs".
%
:- type style_control
---> style_control(string).
% Maps a style control to the style elements we should use for it.
%
:- type style_control_map == map(style_control, style_element_map).
% Return the default style control map.
%
:- func default_style_control_map = style_control_map.
default_style_control_map =
map.from_assoc_list([
( style_control("td.allocations") -
map.from_assoc_list([
style_element("text-align") - "right"
])
),
( style_control("td.callseqs") -
map.from_assoc_list([
style_element("text-align") - "right"
])
),
( style_control("td.clique") -
map.from_assoc_list([
style_element("text-align") - "right"
])
),
( style_control("td.field_name") -
map.from_assoc_list([
style_element("text-align") - "left"
])
),
( style_control("td.memory") -
map.from_assoc_list([
style_element("text-align") - "right"
])
),
( style_control("td.module_name") -
map.from_assoc_list([
style_element("text-align") - "left"
])
),
( style_control("td.number") -
map.from_assoc_list([
style_element("text-align") - "right"
])
),
( style_control("td.ordinal_rank") -
map.from_assoc_list([
style_element("text-align") - "right"
])
),
( style_control("td.port_counts") -
map.from_assoc_list([
style_element("text-align") - "right"
])
),
( style_control("td.proc") -
map.from_assoc_list([
style_element("text-align") - "left"
])
),
( style_control("td.source_context") -
map.from_assoc_list([
style_element("text-align") - "left"
])
),
( style_control("td.ticks_and_times") -
map.from_assoc_list([
style_element("text-align") - "right"
])
),
( style_control("a.control") -
map.from_assoc_list([
style_element("margin") - "5px",
style_element("text-decoration") - "none"
])
),
( style_control("table.plain") -
map.from_assoc_list([
style_element("border-style") - "none"
])
),
( style_control("table.boxed") -
map.from_assoc_list([
style_element("border-width") - "1px 1px 1px 1px",
style_element("border-spacing") - "2px",
style_element("border-style") - "outset outset outset outset"
])
),
( style_control("table.boxed th") -
map.from_assoc_list([
style_element("border-width") - "1px 1px 1px 1px",
style_element("padding") - "3px 3px 3px 3px",
style_element("border-style") - "inset inset inset inset"
])
),
( style_control("table.boxed td") -
map.from_assoc_list([
style_element("border-width") - "1px 1px 1px 1px",
style_element("padding") - "3px 3px 3px 3px",
style_element("border-style") - "inset inset inset inset"
])
)
]).
%---------------------------------------------------------------------------%
% Transform a list of items into HTML.
%
:- pred list_to_html(format_info::in,
style_control_map::in, style_control_map::out,
list_class::in, maybe(string)::in, list(display_item)::in, html::out)
is det.
list_to_html(FormatInfo, !StyleControlMap, Class, MaybeTitle, Items, HTML) :-
(
MaybeTitle = yes(Title),
TitleStartTag = "<span id=\"list_title\">",
TitleEndTag = "</span>\n",
TitleHTML = wrap_tags(TitleStartTag, TitleEndTag,
str_to_html(Title)),
(
Class = list_class_horizontal,
PostTitleHTML = empty_html
;
( Class = list_class_horizontal_except_title
; Class = list_class_vertical_bullets
; Class = list_class_vertical_no_bullets
),
PostTitleHTML = str_to_html("<br>\n")
)
;
MaybeTitle = no,
TitleHTML = empty_html,
PostTitleHTML = empty_html
),
(
( Class = list_class_horizontal
; Class = list_class_horizontal_except_title
),
OutsideStartTag = "",
OutsideEndTag = "\n",
InnerStartTag = "",
InnerEndTag = "\n",
Separator = str_to_html("")
;
Class = list_class_vertical_no_bullets,
OutsideStartTag = "",
OutsideEndTag = "\n",
InnerStartTag = "",
InnerEndTag = "\n",
Separator = str_to_html("<br>\n")
;
Class = list_class_vertical_bullets,
OutsideStartTag = "<ul>\n",
OutsideEndTag = "</ul>\n",
InnerStartTag = "<li>\n",
InnerEndTag = "</li>\n",
Separator = empty_html
),
sep_map_join_html(Separator,
item_to_html(InnerStartTag, InnerEndTag, FormatInfo),
!StyleControlMap, Items, InnerItemsHTML),
ItemsHTML = wrap_tags(OutsideStartTag, OutsideEndTag,
InnerItemsHTML),
HTML = TitleHTML ++ PostTitleHTML ++ ItemsHTML.
%---------------------------------------------------------------------------%
% Transform a deep link into HTML.
%
:- func link_to_html(format_info, deep_link) = html.
link_to_html(FormatInfo, Link) = HTML :-
Link = deep_link(Cmd, MaybePrefs, Label, Class),
deep_cmd_to_url(FormatInfo, Cmd, MaybePrefs, URL),
(
Class = link_class_control,
FormatString = "<a class=\"control\" href=\"%s\">[%s]</a>",
string.format(FormatString,
[s(URL), s(escape_break_html_attr_string(Label))], HTMLStr)
;
Class = link_class_link,
FormatString = "<a class=\"link\" href=\"%s\">%s</a>",
string.format(FormatString,
[s(URL), s(escape_break_html_attr_string(Label))], HTMLStr)
),
HTML = str_to_html(HTMLStr).
% Transform a pseudo link into HTML.
% We should follow the same logic for decoration as link_to_html.
%
:- func pseudo_link_to_html(format_info, pseudo_link) = html.
pseudo_link_to_html(_FormatInfo, PseudoLink) = HTML :-
PseudoLink = pseudo_link(Label, Class),
(
Class = link_class_control,
HTMLStr = "[" ++ escape_break_html_string(Label) ++ "]"
;
Class = link_class_link,
HTMLStr = escape_break_html_string(Label)
),
HTML = str_to_html(HTMLStr).
%---------------------------------------------------------------------------%
% The information we need to create various parts of the HTML.
%
:- type format_info
---> format_info(
% Information about preferences.
fi_pref_colour_scheme :: colour_column_groups,
fi_pref_box :: box_tables,
fi_pref_developer :: developer_mode,
% Information about the current HTTP session, which we use
% to create links.
fi_server_name_port :: string,
fi_script_name :: string,
fi_deep_file :: string
).
:- func init_format_info(deep, preferences) = format_info.
init_format_info(Deep, Prefs) = FormatInfo :-
FormatInfo = format_info(Prefs ^ pref_colour, Prefs ^ pref_box,
Prefs ^ pref_developer_mode,
Deep ^ server_name_port, Deep ^ script_name, Deep ^ data_file_name).
%---------------------------------------------------------------------------%
% Return a URL for the deep structure and command.
%
:- pred deep_cmd_to_url(format_info::in, cmd::in, maybe(preferences)::in,
string::out) is det.
deep_cmd_to_url(FormatInfo, Cmd, MaybePrefs, URL) :-
HostAndPort = FormatInfo ^ fi_server_name_port,
Script = FormatInfo ^ fi_script_name,
DeepFileName = FormatInfo ^ fi_deep_file,
DeepQuery = deep_query(yes(Cmd), DeepFileName, MaybePrefs),
string.format("http://%s%s?%s",
[s(HostAndPort), s(Script), s(query_to_string(DeepQuery))], URL).
%---------------------------------------------------------------------------%
%
% Generic HTML helper predicates.
%
:- func append_htmls(list(html)) = html.
append_htmls(HTMLs) = cord_list_to_cord(HTMLs).
:- func wrap_tags(string, string, html) = html.
wrap_tags(StartTag, EndTag, InnerHTML) =
str_to_html(StartTag) ++ InnerHTML ++ str_to_html(EndTag).
:- func empty_html = html.
empty_html = cord.empty.
:- func str_to_html(string) = html.
str_to_html(Str) = cord.singleton(Str).
%---------------------------------------------------------------------------%
% For each A, MapPred(!StyleControlMap, A, S), and concatenate all Ss.
%
:- pred map_join_html(
pred(style_control_map, style_control_map, A, html)::
in(pred(in, out, in, out) is det),
style_control_map::in, style_control_map::out,
list(A)::in, html::out) is det.
map_join_html(MapPred, !StyleControlMap, List, HTML) :-
sep_map_join_html(empty_html, MapPred, !StyleControlMap, List, HTML).
% For each A, MapPred(!StyleControlMap, A, S), and concatenate all Ss
% after putting Separator between them.
%
:- pred sep_map_join_html(html::in,
pred(style_control_map, style_control_map, A, html)::
in(pred(in, out, in, out) is det),
style_control_map::in, style_control_map::out,
list(A)::in, html::out) is det.
sep_map_join_html(_, _, !StyleControlMap, [], empty_html).
sep_map_join_html(Separator, MapPred, !StyleControlMap, [Head | Tail], HTML) :-
MapPred(!StyleControlMap, Head, HeadHTML),
sep_map_join_html_acc(Separator, MapPred, !StyleControlMap, Tail,
HeadHTML, HTML).
:- pred sep_map_join_html_acc(html::in,
pred(style_control_map, style_control_map, A, html)::
in(pred(in, out, in, out) is det),
style_control_map::in, style_control_map::out,
list(A)::in, html::in, html::out) is det.
sep_map_join_html_acc(_, _, !StyleControlMap, [], !HTML).
sep_map_join_html_acc(Separator, MapPred, !StyleControlMap, [Head | Tail],
!HTML) :-
MapPred(!StyleControlMap, Head, HeadHTML),
!:HTML = !.HTML ++ Separator ++ HeadHTML,
sep_map_join_html_acc(Separator, MapPred, !StyleControlMap, Tail, !HTML).
% For each A, MapPred(!StyleControlMap, N, A, S), and concatenate all Ss.
% N is the ordinal number of the element in the list.
%
:- pred map_join_html_count(
pred(style_control_map, style_control_map, int, int, A, html)::
in(pred(in, out, in, out, in, out) is det),
style_control_map::in, style_control_map::out,
int::in, list(A)::in, html::out) is det.
map_join_html_count(MapPred, !StyleControlMap, !.ColumnNum, List, HTML) :-
sep_map_join_html_count(empty_html, MapPred, !StyleControlMap, !.ColumnNum,
List, HTML).
% For each A, MapPred(!StyleControlMap, N, A, S), and concatenate all Ss
% after putting Separator between them.
% N is the ordinal number of the element in the list.
%
:- pred sep_map_join_html_count(html::in,
pred(style_control_map, style_control_map, int, int, A, html)::
in(pred(in, out, in, out, in, out) is det),
style_control_map::in, style_control_map::out,
int::in, list(A)::in, html::out) is det.
sep_map_join_html_count(_, _, !StyleControlMap, _, [], empty_html).
sep_map_join_html_count(Separator, MapPred, !StyleControlMap, !.ColumnNum,
[Head | Tail], HTML) :-
MapPred(!StyleControlMap, !ColumnNum, Head, HeadHTML),
sep_map_join_html_count_acc(Separator, MapPred, !StyleControlMap,
!.ColumnNum, Tail, HeadHTML, HTML).
:- pred sep_map_join_html_count_acc(html::in,
pred(style_control_map, style_control_map, int, int, A, html)::
in(pred(in, out, in, out, in, out) is det),
style_control_map::in, style_control_map::out,
int::in, list(A)::in, html::in, html::out) is det.
sep_map_join_html_count_acc(_, _, !StyleControlMap, _, [], !HTML).
sep_map_join_html_count_acc(Separator, MapPred, !StyleControlMap, !.ColumnNum,
[Head | Tail], !HTML) :-
MapPred(!StyleControlMap, !ColumnNum, Head, HeadHTML),
!:HTML = !.HTML ++ Separator ++ HeadHTML,
sep_map_join_html_count_acc(Separator, MapPred, !StyleControlMap,
!.ColumnNum, Tail, !HTML).
%---------------------------------------------------------------------------%
escape_html_string(String) =
replace_special_chars(special_html_char, String).
escape_html_attr_string(attr_str(Attrs, String)) =
handle_html_attrs(Attrs, replace_special_chars(special_html_char, String)).
escape_break_html_string(String) =
replace_special_chars(special_html_char_or_break, String).
escape_break_html_attr_string(attr_str(Attrs, String)) =
handle_html_attrs(Attrs,
replace_special_chars(special_html_char_or_break, String)).
:- func handle_html_attrs(list(str_attr), string) = string.
handle_html_attrs([], Str) = Str.
handle_html_attrs([Attr | Attrs], InsideStr) = Str :-
InnerStr = handle_html_attrs(Attrs, InsideStr),
(
Attr = attr_bold,
Str = "<b>" ++ InnerStr ++ "</b>"
;
Attr = attr_italic,
Str = "<i>" ++ InnerStr ++ "</i>"
;
Attr = attr_underline,
Str = "<u>" ++ InnerStr ++ "</u>"
).
:- func replace_special_chars(pred(char, string)::in(pred(in, out) is semidet),
string::in) = (string::out) is det.
replace_special_chars(SpecialCharTable, String0) = String :-
string.foldr(replace_special_char_2(SpecialCharTable), String0, [], Chars),
string.from_char_list(Chars, String).
:- pred replace_special_char_2(
pred(char, string)::in(pred(in, out) is semidet),
char::in, list(char)::in, list(char)::out) is det.
replace_special_char_2(SpecialCharTable, Char, !Acc) :-
( if SpecialCharTable(Char, String) then
string.to_char_list(String, Chars),
list.append(Chars, !Acc)
else
list.cons(Char, !Acc)
).
:- pred special_html_char(char::in, string::out) is semidet.
special_html_char('&', "&amp;").
special_html_char('<', "&lt;").
special_html_char('>', "&gt;").
special_html_char('''', "&apos;").
special_html_char('"', "&quot;").
% In addition to escaping special HTML characters, insert zero-width space
% characters to suggest where the browser may split up long sequences of
% characters over multiple lines.
%
:- pred special_html_char_or_break(char::in, string::out) is semidet.
special_html_char_or_break('&', "&amp;").
special_html_char_or_break('<', "&lt;").
special_html_char_or_break('>', "&gt;").
special_html_char_or_break('''', "&apos;").
special_html_char_or_break('"', "&quot;").
special_html_char_or_break('.', "." ++ zero_width_space).
special_html_char_or_break('_', "_" ++ zero_width_space).
special_html_char_or_break('/', "/" ++ zero_width_space).
special_html_char_or_break(':', ":" ++ zero_width_space).
% U+8203 is the Unicode 'ZERO WIDTH SPACE' character. It is supported
% by modern browsers, but tends to break search as the invisible character
% is not ignored when searching.
%
% The <WBR> tag is non-standard but doesn't break search in Firefox (at
% least).
%
:- func zero_width_space = string.
% zero_width_space = "&#8203;".
zero_width_space = "<wbr />".
%---------------------------------------------------------------------------%
:- end_module html_format.
%---------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink