## html-device.sml
## A pretty printing device that uses HTML markup to control layout.
# Compiled by:
# src/lib/prettyprint/big/devices/prettyprint-devices.sublibpackage html_device: (weak) api {
include Prettyprint_Device; # Prettyprint_Device is from src/lib/prettyprint/big/src/prettyprint-device.api # Combine two styles into one:
#
combine_style: ((Style, Style)) -> Style;
# Unstyled text:
#
style_none: Style;
# Standard HTML text styles:
#
style_tt: Style;
style_i: Style;
style_b: Style;
style_u: Style;
style_strike: Style;
style_em: Style;
style_strong: Style;
style_dfn: Style;
style_code: Style;
style_samp: Style;
style_kbd: Style;
style_var: Style;
style_cite: Style;
# Color text (using FONT element):
#
color: String -> Style;
# Hyper-text links and anchors:
#
link: String -> Style;
anchor: String -> Style;
link_anchor: { name: String, href: String } -> Style;
open_device: { wid: Int, text_wide: Null_Or( Int ) } -> Device;
done: Device -> html::Text;
}
{
Style
= NOEMPH
| TT | II | BB | UU | STRIKE | EM
| STRONG | DFN | CODE | SAMP | KBD
| VAR | CITE
| COLOR String
| AA { href: Null_Or( String ), name: Null_Or( String ) }
| STYS List( Style )
;
Device = DEV {
line_wid: Int,
text_wide: Null_Or( Int ),
emph_stk: Ref( List( (List( html::Text ), Style) ) ) ,
txt: Ref( List( html::Text ) )
};
# Return the current emphasis
#
fun cur_emph (DEV { emph_stk, ... } )
=
case *emph_stk
[] => NOEMPH;
((_, em) ! r) => em;
esac;
# Add PCDATA to the text list
#
fun pcdata (DEV { txt, ... }, s)
=
txt := html::PCDATA s ! *txt;
# Replace the sequence of PCDATA elements at
# the head of the txt list with its concatenation.
#
fun join_txt (DEV { txt, ... } )
=
f (*txt, [])
where
fun f ([], []) => [];
f (html::PCDATA s ! r, l) => f (r, s ! l);
f (r, l) => html::PCDATA (string::cat l) ! r;
end;
end;
# Are two styles the same?
#
fun same_style (s1: Style, s2)
=
s1 == s2;
fun wrap_style (sty, [], tl')
=>
tl';
wrap_style (sty, tl, tl')
=>
wrap (sty, t) ! tl'
where
fun wrap (NOEMPH, t) => t;
wrap (TT, t) => html::TT t;
wrap (II, t) => html::IX t;
wrap (BB, t) => html::BX t;
wrap (UU, t) => html::UX t;
wrap (STRIKE, t) => html::STRIKE t;
wrap (EM, t) => html::EM t;
wrap (STRONG, t) => html::STRONG t;
wrap (DFN, t) => html::DFN t;
wrap (CODE, t) => html::CODE t;
wrap (SAMP, t) => html::SAMP t;
wrap (KBD, t) => html::KBD t;
wrap (VAR, t) => html::VAR t;
wrap (CITE, t) => html::CITE t;
wrap (COLOR c, t) => html::FONT { color=>THE c, size=>NULL, content=>t };
wrap (AA { name, href }, t) => html::AX {
name, href,
rel => NULL, reverse => NULL, title => NULL,
content => t
};
wrap (STYS l, t) => list::fold_backward wrap t l;
end;
t = case tl
[t] => t;
_ => html::TEXT_LIST (list::reverse tl);
esac;
end;
end;
# Push/pop a style from the devices style stack.
# A pop on an empty style stack is a no-op.
fun push_style (dev as DEV { emph_stk, txt, ... }, sty)
=
{ emph_stk := (join_txt dev, sty) ! *emph_stk;
txt := [];
};
fun pop_style (DEV { emph_stk as REF [], ... } )
=>
();
pop_style (dev as DEV { emph_stk as REF ((tl, sty) ! r), txt, ... } )
=>
{ txt := wrap_style (sty, join_txt dev, tl);
emph_stk := r;
};
end;
# The default style for the device. (This is the current style,
# if the style stack is empty).
#
fun default_style _
=
NOEMPH;
# Maximum printing depth (in terms of boxes)
#
fun depth _
=
NULL;
# The width of the device
#
fun line_width (DEV { line_wid, ... } )
=
THE line_wid;
# The suggested maximum width of text on a line
#
fun text_width (DEV { text_wide, ... } )
=
text_wide;
# Write some number of spaces to the device:
#
fun space (dev, n)
=
pcdata (dev, cat (list::from_fn (n, fn _ => " "; end )));
# Write a new-line to the device:
#
fun newline (dev as DEV { txt, ... } )
=
txt := html::BR { clear=>NULL } ! (join_txt dev);
# Write a string/character in the current style to the device:
string = pcdata;
fun char (dev, c)
=
pcdata (dev, str c);
# Flush is a nop for us:
fun flush _ = ();
fun combine_style (NOEMPH, sty) => sty;
combine_style (sty, NOEMPH) => sty;
combine_style (STYS l1, STYS l2) => STYS (l1 @ l2);
combine_style (sty, STYS l) => STYS (sty ! l);
combine_style (sty1, sty2) => STYS [sty1, sty2];
end;
style_none = NOEMPH;
style_tt = TT;
style_i = II;
style_b = BB;
style_u = UU;
style_strike = STRIKE;
style_em = EM;
style_strong = STRONG;
style_dfn = DFN;
style_code = CODE;
style_samp = SAMP;
style_kbd = KBD;
style_var = VAR;
style_cite = CITE;
color = COLOR;
fun link s = AA { href=>THE s, name=>NULL };
fun anchor s = AA { href=>NULL, name=>THE s };
fun link_anchor { name, href } = AA { href=>THE href, name => THE name };
fun open_device { wid, text_wide }
=
DEV { txt => REF [],
emph_stk => REF [],
line_wid => wid,
text_wide
};
fun done (dev as DEV { emph_stk => REF [], txt, ... } )
=>
case (join_txt dev)
[t] => { txt := []; t; };
l => { txt := []; html::TEXT_LIST (list::reverse l); };
esac;
done _
=>
raise exception FAIL "device is not done yet";
end;
}; # html_device