PreviousUpNext

15.4.815  src/lib/html/pr-html.pkg

## pr-html.pkg
#
# Prettyprint an HTML tree.

# Compiled by:
#     src/lib/html/html.lib

stipulate
    package has =  html_abstract_syntax;                                                        # html_abstract_syntax                  is from   src/lib/html/html-abstract-syntax.pkg
herein

    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;


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext