## pr-html.pkg
#
# Prettyprint an HTML tree.
# Compiled by:
# src/lib/html/html.libstipulate
package has = html_abstract_syntax; # html_abstract_syntax is from src/lib/html/html-abstract-syntax.pkgherein
package unparse_html_tree: (weak)
api {
unparse_html_tree: {
putc: Char -> Void,
puts: String -> Void
} -> has::Html -> Void;
}
{
package has = html_abstract_syntax; # html_abstract_syntax is from src/lib/html/html-abstract-syntax.pkg package f= sfprintf; # sfprintf is from src/lib/src/sfprintf.pkg Output_Stream
=
OS {
putc: Char -> Void,
puts: String -> Void
};
fun putc (OS { putc, ... }, c) = putc c;
fun puts (OS { puts, ... }, s) = puts s;
Attribute_Data
= IMPLICIT Bool
| CDATA Null_Or( String )
| NAME Null_Or( String )
| NUMBER Null_Or( Int )
;
stipulate
fun name to_string NULL => NAME NULL;
name to_string (THE x) => NAME (THE (to_string x));
end;
herein
http_method = name has::http_method::to_string;
input_type = name has::input_type::to_string;
i_align = name has::ialign::to_string;
h_align = name has::halign::to_string;
cell_valign = name has::cell_valign::to_string;
caption_align = name has::caption_align::to_string;
ul_style = name has::ulstyle::to_string;
shape = name has::shape::to_string;
text_flow_ctl = name has::text_flow_ctl::to_string;
end; # local
fun fmt_tag (tag, [])
=>
cat ["<", tag, ">"];
fmt_tag (tag, attributes)
=>
{ fun fmt_attribute (attribute_name, IMPLICIT TRUE)
=>
THE attribute_name;
fmt_attribute (attribute_name, CDATA (THE s))
=>
THE (f::sprintf' "%s=\"%s\"" [f::STRING attribute_name, f::STRING s]);
fmt_attribute (attribute_name, NAME (THE s))
=>
THE (f::sprintf' "%s=%s" [f::STRING attribute_name, f::STRING s]);
fmt_attribute (attribute_name, NUMBER (THE n))
=>
THE (f::sprintf' "%s=%d" [f::STRING attribute_name, f::INT n]);
fmt_attribute _
=>
NULL;
end;
attributes = list::map_partial_fn fmt_attribute attributes;
list_to_string::list_to_string' {
first => "<",
between => " ",
last => ">",
to_string => \\ x = x
} (tag ! attributes);
};
end;
fun fmt_end_tag tag = cat ["</", tag, ">"];
fun pr_tag (OS { puts, ... }, tag, attributes) = puts (fmt_tag (tag, attributes));
fun pr_end_tag (OS { puts, ... }, tag ) = puts (fmt_end_tag tag);
fun new_line (OS { putc, ... } ) = putc '\n';
fun space (OS { putc, ... } ) = putc ' ';
# NOTE: once we are doing linebreaks for text,
# this becomes important.
fun set_pre (_, _) = ();
fun pr_block (stream, blk: has::Block)
=
case blk
has::BLOCK_LIST bl
=>
list::apply (\\ b = pr_block (stream, b)) bl;
has::TEXTABLOCK txt
=>
{ pr_text (stream, txt);
new_line stream;
};
has::HN { n, align, content }
=>
{ tag = "H" + int::to_string n;
pr_tag (stream, tag, [("align", h_align align)]);
pr_text (stream, content);
pr_end_tag (stream, tag);
new_line stream;
};
has::ADDRESS blk
=>
{ pr_tag (stream, "ADDRESS", []);
new_line stream;
pr_block (stream, blk);
pr_end_tag (stream, "ADDRESS");
new_line stream;
};
has::PP { align, content }
=>
{ pr_tag (stream, "P", [("ALIGN", h_align align)]);
new_line stream;
pr_text (stream, content);
new_line stream;
};
has::UL { type, compact, content }
=>
{ pr_tag (stream, "UL", [
("TYPE", ul_style type),
("COMPACT", IMPLICIT compact)
]);
new_line stream;
pr_list_items (stream, content);
pr_end_tag (stream, "UL");
new_line stream;
};
has::OL { type, start, compact, content }
=>
{ pr_tag (stream, "OL", [
("TYPE", CDATA type),
("START", NUMBER start),
("COMPACT", IMPLICIT compact)
]);
new_line stream;
pr_list_items (stream, content);
pr_end_tag (stream, "OL");
new_line stream;
};
has::DIR { compact, content }
=>
{ pr_tag (stream, "DIR", [("COMPACT", IMPLICIT compact)]);
new_line stream;
pr_list_items (stream, content);
pr_end_tag (stream, "DIR");
new_line stream;
};
has::MENU { compact, content }
=>
{ pr_tag (stream, "MENU", [("COMPACT", IMPLICIT compact)]);
new_line stream;
pr_list_items (stream, content);
pr_end_tag (stream, "MENU");
new_line stream;
};
has::DL { compact, content }
=>
{ pr_tag (stream, "DL", [("COMPACT", IMPLICIT compact)]);
new_line stream;
pr_dlitems (stream, content);
pr_end_tag (stream, "DL");
new_line stream;
};
has::PRE { width, content }
=>
{ pr_tag (stream, "PRE", [("WIDTH", NUMBER width)]);
new_line stream;
set_pre (stream, TRUE);
pr_text (stream, content);
set_pre (stream, FALSE);
new_line stream;
pr_end_tag (stream, "PRE");
new_line stream;
};
has::DIV { align, content }
=>
{ pr_tag (stream, "DIV", [("ALIGN", h_align (THE align))]);
new_line stream;
pr_block (stream, content);
pr_end_tag (stream, "DIV");
new_line stream;
};
has::CENTER bl
=>
{ pr_tag (stream, "CENTER", []);
new_line stream;
pr_block (stream, bl);
pr_end_tag (stream, "CENTER");
new_line stream;
};
has::BLOCKQUOTE bl
=>
{ pr_tag (stream, "BLOCKQUOTE", []);
new_line stream;
pr_block (stream, bl);
pr_end_tag (stream, "BLOCKQUOTE");
new_line stream;
};
has::FORM { action, method', enctype, content }
=>
{ pr_tag (stream, "FORM", [
("ACTION", CDATA action),
("METHOD", http_method (THE method')),
("ENCTYPE", CDATA enctype)
]);
new_line stream;
pr_block (stream, content);
pr_end_tag (stream, "FORM");
new_line stream;
};
has::ISINDEX { prompt }
=>
{ pr_tag (stream, "ISINDEX", [("PROMPT", CDATA prompt)]);
new_line stream;
};
has::HR { align, noshade, size, width }
=>
{ pr_tag (stream, "HR", [
("ALIGN", h_align align),
("NOSHADE", IMPLICIT noshade),
("SIZE", CDATA size),
("WIDTH", CDATA width)
]);
new_line stream;
};
has::TABLE {
align, width, border, cellspacing, cellpadding,
caption, content
}
=>
{ pr_tag (stream, "TABLE", [
("ALIGN", h_align align),
("WIDTH", CDATA width),
("BORDER", CDATA border),
("CELLSPACING", CDATA cellspacing),
("CELLPADDING", CDATA cellpadding)
]);
new_line stream;
pr_caption (stream, caption);
pr_table_rows (stream, content);
pr_end_tag (stream, "TABLE");
new_line stream;
};
esac
also
fun pr_list_items (stream, items)
=
list::apply print_item items
where
fun print_item (has::LI { type, value, content } )
=
{
pr_tag (stream, "LI", [("TYPE", CDATA type), ("VALUE", NUMBER value)]);
new_line stream;
pr_block (stream, content);
};
end
also
fun pr_dlitems (stream, items)
=
list::apply print_item items
where
fun pr_dt txt
=
{ pr_tag (stream, "DT", []);
space stream;
pr_text (stream, txt);
new_line stream;
};
fun pr_dd blk
=
{ pr_tag (stream, "DD", []);
new_line stream;
pr_block (stream, blk);
};
fun print_item ( { dt, dd } )
=
{ list::apply pr_dt dt;
pr_dd dd;
};
end
also
fun pr_caption (stream, THE (has::CAPTION { align, content } ))
=>
{ pr_tag (stream, "CAPTION", [("ALIGN", caption_align align)]);
new_line stream;
pr_text (stream, content);
pr_end_tag (stream, "CAPTION");
new_line stream;
};
pr_caption (stream, NULL)
=>
();
end
also
fun pr_table_rows (stream, rows)
=
list::apply pr_tr rows
where
fun pr_tr (has::TR { align, valign, content } )
=
{ pr_tag (stream, "TR", [
("ALIGN", h_align align),
("VALIGN", cell_valign valign)
]);
new_line stream;
list::apply (pr_table_cell stream) content;
};
end
also
fun pr_table_cell stream cell
=
case cell
(has::TH stuff) => pr_cell ("TH", stuff);
(has::TD stuff) => pr_cell ("TD", stuff);
esac
where
fun pr_cell (tag, {
nowrap, rowspan, colspan, align, valign, width, height,
content
} )
=
{ pr_tag (stream, tag, [
("NOWRAP", IMPLICIT nowrap),
("ROWSPAN", NUMBER rowspan),
("COLSPAN", NUMBER colspan),
("ALIGN", h_align align),
("VALIGN", cell_valign valign),
("WIDTH", CDATA width),
("HEIGHT", CDATA height)
]);
new_line stream;
pr_block (stream, content);
};
end
also
fun pr_emph (stream, tag, text)
=
{ pr_tag (stream, tag, []);
pr_text (stream, text);
pr_end_tag (stream, tag);
}
also
fun pr_text (stream, text)
=
case text
has::TEXT_LIST tl
=>
list::apply (\\ txt = pr_text (stream, txt)) tl;
has::PCDATA pcdata => pr_pcdata (stream, pcdata);
has::TT txt => pr_emph (stream, "TT", txt);
has::IX txt => pr_emph (stream, "I", txt);
has::BX txt => pr_emph (stream, "B", txt);
has::UX txt => pr_emph (stream, "U", txt);
has::STRIKE txt => pr_emph (stream, "STRIKE", txt);
has::BIG txt => pr_emph (stream, "BIG", txt);
has::SMALL txt => pr_emph (stream, "SMALL", txt);
has::SUB txt => pr_emph (stream, "SUB", txt);
has::SUP txt => pr_emph (stream, "SUP", txt);
has::EM txt => pr_emph (stream, "EM", txt);
has::STRONG txt => pr_emph (stream, "STRONG", txt);
has::DFN txt => pr_emph (stream, "DFN", txt);
has::CODE txt => pr_emph (stream, "CODE", txt);
has::SAMP txt => pr_emph (stream, "SAMP", txt);
has::KBD txt => pr_emph (stream, "KBD", txt);
has::VAR txt => pr_emph (stream, "VAR", txt);
has::CITE txt => pr_emph (stream, "CITE", txt);
has::AX { name, href, rel, reverse, title, content }
=>
{ pr_tag (stream, "A", [
("NAME", CDATA name),
("HREF", CDATA href),
("REL", CDATA rel),
("REV", CDATA reverse),
("TITLE", CDATA title)
]);
pr_text (stream, content);
pr_end_tag (stream, "A");
};
has::IMG {
src, alt, align, height, width, border,
hspace, vspace, usemap, ismap
}
=>
pr_tag (stream, "IMG", [
("SRC", CDATA (THE src)),
("ALT", CDATA alt),
("ALIGN", i_align align),
("HEIGHT", CDATA height),
("WIDTH", CDATA width),
("BORDER", CDATA border),
("HSPACE", CDATA hspace),
("VSPACE", CDATA vspace),
("USEMAP", CDATA usemap),
("ISMAP", IMPLICIT ismap)
]);
has::APPLET {
codebase, code, name, alt, align, height, width,
hspace, vspace, content
}
=>
{ pr_tag (stream, "APPLET", [
("CODEBASE", CDATA codebase),
("CODE", CDATA (THE code)),
("NAME", CDATA name),
("ALT", CDATA alt),
("ALIGN", i_align align),
("HEIGHT", CDATA height),
("WIDTH", CDATA width),
("HSPACE", CDATA hspace),
("VSPACE", CDATA vspace)
]);
pr_text (stream, content);
pr_end_tag (stream, "APPLET");
};
has::PARAM { name, value }
=>
pr_tag (stream, "PARAM", [
("NAME", NAME (THE name)),
("VALUE", CDATA value)
]);
has::FONT { size, color, content }
=>
{ pr_tag (stream, "FONT", [
("SIZE", CDATA size),
("COLOR", CDATA color)
]);
pr_text (stream, content);
pr_end_tag (stream, "FONT");
};
has::BASEFONT { size, content }
=>
{ pr_tag (stream, "BASEFONT", [("SIZE", CDATA size)]);
pr_text (stream, content);
pr_end_tag (stream, "BASEFONT");
};
has::BR { clear }
=>
{ pr_tag (stream, "BR", [("CLEAR", text_flow_ctl clear)]);
new_line stream;
};
has::MAP { name, content }
=>
{ pr_tag (stream, "MAP", [("NAME", CDATA name)]);
list::apply (pr_area stream) content;
pr_end_tag (stream, "MAP");
};
has::INPUT { type, name, value, checked, size, maxlength, src, align }
=>
pr_tag (stream, "INPUT", [
("TYPE", input_type type),
("NAME", NAME name),
("VALUE", CDATA value),
("CHECKED", IMPLICIT checked),
("SIZE", CDATA size),
("MAXLENGTH", NUMBER maxlength),
("SRC", CDATA src),
("ALIGN", i_align align)
]);
has::SELECT { name, size, content }
=>
{ pr_tag (stream, "SELECT", [
("NAME", NAME (THE name)),
("SIZE", NUMBER size)
]);
list::apply (pr_option stream) content;
pr_end_tag (stream, "SELECT");
};
has::TEXTAREA { name, rows, cols, content }
=>
{ pr_tag (stream, "TEXTAREA", [
("NAME", NAME (THE name)),
("ROWS", NUMBER (THE rows)),
("COLS", NUMBER (THE cols))
]);
pr_pcdata (stream, content);
pr_end_tag (stream, "TEXTAREA");
};
# SCRIPT elements are placeholders
# for the next version of HTML
#
has::SCRIPT pcdata
=>
();
esac
also
fun pr_area stream (has::AREA { shape=>s, coords, href, nohref, alt } )
=
pr_tag (stream, "AREA", [
("SHAPE", shape s),
("COORDS", CDATA coords),
("HREF", CDATA href),
("nohref", IMPLICIT nohref),
("ALT", CDATA (THE alt))
])
also
fun pr_option stream (has::OPTION { selected, value, content } )
=
{
pr_tag (stream, "OPTION", [
("SELECTED", IMPLICIT selected),
("VALUE", CDATA value)
]);
pr_pcdata (stream, content);
}
also
fun pr_pcdata (stream, data)
=
puts (stream, data);
fun pr_body (stream, has::BODY {
background, bgcolor, text, link, vlink, alink, content
} )
=
{ pr_tag (stream, "BODY", [
("BACKGROUND", CDATA background),
("BGCOLOR", CDATA bgcolor),
("TEXT", CDATA text),
("LINK", CDATA link),
("VLINK", CDATA vlink),
("ALINK", CDATA alink)
]);
pr_block (stream, content);
pr_end_tag (stream, "BODY");
};
fun pr_head_element stream element
=
case element
has::HEAD_TITLE pcdata
=>
{ pr_tag (stream, "TITLE", []);
pr_pcdata (stream, pcdata);
pr_end_tag (stream, "TITLE");
new_line stream;
};
has::HEAD_ISINDEX { prompt }
=>
{ pr_tag (stream, "ISINDEX", [("PROMPT", CDATA prompt)]);
new_line stream;
};
has::HEAD_BASE { href }
=>
{ pr_tag (stream, "BASE", [("HREF", CDATA (THE href))]);
new_line stream;
};
has::HEAD_META { http_equiv, name, content }
=>
{ pr_tag (stream, "META", [
("HTTP-EQUIV", NAME http_equiv),
("NAME", NAME name),
("CONTENT", CDATA (THE content))
]);
new_line stream;
};
has::HEAD_LINK { id, href, rel, reverse, title }
=>
{ pr_tag (stream, "LINK", [
("ID", NAME id),
("HREF", CDATA href),
("REL", CDATA rel),
("REV", CDATA reverse),
("TITLE", CDATA title)
]);
new_line stream;
};
# SCRIPT/STYLE elements are placeholders
# for the next version of HTML
has::HEAD_SCRIPT pcdata => ();
has::HEAD_STYLE pcdata => ();
esac;
fun unparse_html_tree { putc, puts } html
=
{ stream = OS { putc, puts };
#
html -> has::HTML { head, body, version };
case version
#
THE v => puts (f::sprintf'
"<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML %s//EN\">\n"
[f::STRING v]);
NULL => ();
esac;
puts "<HTML>\n";
puts "<HEAD>\n";
list::apply (pr_head_element stream) head;
puts "</HEAD>\n";
pr_body (stream, body);
puts "</HTML>\n";
};
};
end;