PreviousUpNext

15.4.829  src/lib/prettyprint/big/devices/html-dev.pkg

## html-device.sml
## A pretty printing device that uses HTML markup to control layout.

# Compiled by:
#     src/lib/prettyprint/big/devices/prettyprint-devices.sublib

package 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 



Comments and suggestions to: bugs@mythryl.org

PreviousUpNext