%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 2001-2002, 2004-2012 The University of Melbourne.
% Copyright (C) 2015, 2017, 2019, 2021-2022, 2025 The Mercury team.
% 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 display.
:- import_module profile.
:- import_module query.
%---------------------------------------------------------------------------%
% 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("", "
\n", TitleHTML)
),
HeadTitleHTML = wrap_tags("", "\n", HeadTitle),
FormatInfo = init_format_info(Deep, Prefs),
StyleControlMap0 = default_style_control_map,
map_join_html(item_to_html("\n", "
\n", FormatInfo),
StyleControlMap0, StyleControlMap, Items, ItemsHTML),
StyleHTML = css_style_html(StyleControlMap),
HTML = doc_type_html ++
wrap_tags("\n", "\n",
wrap_tags("\n", "\n", HeadTitleHTML ++ StyleHTML) ++
wrap_tags("\n", "\n", HeadingHTML ++ ItemsHTML)
),
HTMLStr = string.append_list(cord.list(HTML)).
:- func doc_type_html = html.
doc_type_html =
str_to_html(
"\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("\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("", "
\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("\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("
", "
", 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 = "\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("\n", "
\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("\n", "
\n", InnerHeaderRowTwoHTML)
),
InnerHeaderRowThree =
string.format("", [i(NumColumns)]),
HeaderRowThreeHTML =
wrap_tags(" | ", "
", 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("\n", "\n", HeaderHTML),
WrappedBodyHTML = wrap_tags("\n", "\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, StyleControlMap, HeaderGroup, HTML) :-
% We do not read or update StyleControlMap, but the argument pair
% returning StyleControlMap unchanged is required by map_join_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(
"",
[s(RowSpan), s(ColumnSpan), s(ColumnClassStr)]),
EndTag = " | \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, StyleControlMap, TableData, HTML) :-
% We do not read or update StyleControlMap, but the argument pair
% returning StyleControlMap unchanged is required by map_join_html.
ColumnClassStr = table_column_class_to_string(ColumnClass),
TableDataHTML = table_data_to_html(FormatInfo, TableData),
StartTag = string.format("", [s(ColumnClassStr)]),
EndTag = " | \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($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("| ", [i(NumColumns)]),
EndTag = " |
\n",
HTML = wrap_tags(StartTag, EndTag, ContentsHTML)
;
TableRow = table_separator_row,
Str = string.format(" |
\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("\n", "
\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, StyleControlMap,
!ColumnNum, Cell, HTML) :-
% We do not read or update StyleControlMap, but the argument pair
% returning StyleControlMap unchanged is required by map_join_html_count.
(
Cell = table_empty_cell,
!:ColumnNum = !.ColumnNum + 1,
HTML = str_to_html(" | ")
;
(
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($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("",
[s(SpanStr), s(ColumnClassStr)]),
EndTag = " | \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 = "",
TitleEndTag = "\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("
\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("
\n")
;
Class = list_class_vertical_bullets,
OutsideStartTag = "\n",
InnerStartTag = "\n",
InnerEndTag = "\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 = "[%s]",
string.format(FormatString,
[s(URL), s(escape_break_html_attr_string(Label))], HTMLStr)
;
Class = link_class_link,
FormatString = "%s",
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 = "" ++ InnerStr ++ ""
;
Attr = attr_italic,
Str = "" ++ InnerStr ++ ""
;
Attr = attr_underline,
Str = "" ++ InnerStr ++ ""
).
:- 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('&', "&").
special_html_char('<', "<").
special_html_char('>', ">").
special_html_char('''', "'").
special_html_char('"', """).
% 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('&', "&").
special_html_char_or_break('<', "<").
special_html_char_or_break('>', ">").
special_html_char_or_break('''', "'").
special_html_char_or_break('"', """).
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 tag is non-standard but doesn't break search in Firefox (at
% least).
%
:- func zero_width_space = string.
% zero_width_space = "".
zero_width_space = "".
%---------------------------------------------------------------------------%
:- end_module html_format.
%---------------------------------------------------------------------------%