#! /usr/local/bin/perl5 -w
#
# This program generates a grammar for HTML
#
# Elements for which open tags aren't required should be defined explicitly!

use strict;

# this program generates a parser based on the definition in loose.dtd
# things changed for asshole compliance:
# --------------------------------------
# head tags may appear BEFORE the html open tag
# basefont tag may appear in the head
# address close tag is made optional
# headings h1-h6 are defined to contain only inline data, but we allow flow
# html head section is made optional
# forms and fonts no longer have structure; we only recognize
#                       their tags seperately
# flow-rubbish accepted between the head and the body
# we accept more than one head before the body
# we accept tr and td elements without open or close tags
# anchors need no closing tag
# (in the tokenizer:) sgml comments can be closed with more than 2 hyphens

my %ELTS;

my %elts = 
  ("block"        => "[p) heading a_list [pre] [div] [noscript] [center] " .
                     "[blockquote] .hr [table] [fieldset] [address) " .
                     "[noframes] [ins] [del] .isindex (form) " .
                     "[layer] [ilayer] [nolayer]",
   "heading"      => "[h1] [h2] [h3] [h4] [h5] [h6]",
   "a_list"       => "[ul] [ol] [dl] [dir] [menu]",
   "inline"       => "[a) fontstyle phrase special formctrl",
   "fontstyle"    => "[tt] [i] [b] [big] [small] [u] [s] ".
                     "[strike] [blink] [marquee] [nobr]",
   "formctrl"     => ".input [select] [textarea] [label] [button]",
   "special"      => ".img .br [script] [map] [q] [sub] [sup] " .
                     "[span] [bdo] (font) .basefont [iframe]",
   "phrase"       => "[em] [strong] [dfn] [code] [samp] [kbd] [var] [cite] " .
                     "[abbr] [acronym]",

   "head_misc"    => "[style] .meta .link .base [title] [object]",
   
   "-list_conts"  => "[dt) [dd) [li)",
   "-table_conts" => "[caption] [thead) [tfoot) [tbody) [colgroup) .col ".
                     "(tr) [th) (td)",
   "-misc_elts"   => ".area .param (head) (body) [html] " .
                     "[frameset] [legend] [optgroup] [option) [applet] " .
                     ".frame",
  );

my %contents = complete
  ("block"       => "(*! (/! block inline))",
   "inline"      => "(*! inline)",
   "pre"         => "(*! inline)",
   "button"      => "(*! (/! block inline))",
   "p"           => "otc ".many("block"), 
   "table"       => "otc ".maybe("caption_elt") . " " .
                    many("(/! col_tag colgroup_elt)") . " " .
                    "(/! implicit_tbody " .
			"(\$ " . maybe("thead_elt") . " " .
			         maybe("tfoot_elt") . " " .
			         many("tbody_elt") .
			")" .
		    ")",
   "-table_conts"=> "otc ".many("tr_elt"),
   "caption"     => "(*! inline)",
   "colgroup"    => "otc ".many("col_tag"),
   "th"          => "(*! (/! block inline))",
   "a_list"      => "otc ".many("li_elt"),
   "dl"          => "otc ".many("(/! dt_elt dd_elt)"),
   "-list_conts" => "(*! (/! block inline))",
   "dt"          => "(*! inline)",
   "map"         => "otc ".many("(/! block area_tag)"),
   "script"      => "otc",
   "title"       => "otc",
   "html"        => "otc ".many("head_elt") . " flow_rubbish " .
                    "(/! body_elt frameset_elt) flow_rubbish",
   "iframe"      => "otc ".many("(/! block inline)"),
   "textarea"    => "otc",
   "frameset"    => "otc ".many("(/! frameset_elt frame_tag)")." ".
			   maybe("noframes_elt"),
   "fieldset"    => "otc legend_elt otc ".many("block"),
   "style"       => "otc",
   "object"      => "(*! (/! param_tag block))",
   "applet"      => "(*! (/! param_tag block))",
   "select"      => "otc ".many("(/! optgroup_elt option_elt)"),
   "optgroup"    => "otc ".many("option_elt"),
   "-misc_elts"  => "(*! inline)",
   "address"     => "(*! (/! inline p_elt))",
   "p"           => "(*! inline)",
   "a"           => "in_anchor",
  );

my %added_alternatives =
  ("inline"      => "ins_elt del_elt tc form_elt",
   "head_misc"   => "script_elt basefont_tag",
  );

sub many  { my $elt = shift; "(*! (\$ $elt otc))" }
sub maybe { my $elt = shift; "(?! (\$ $elt otc))" }

prologue();
make_rules();
epilogue();

for (sort keys %ELTS) { print STDERR "$_\n" }
print STDERR "\nCode generated for ".scalar(keys %ELTS)." elts\n";
exit;

sub make_rules {
  while (my ($group, $el_string) = each %elts) {

    # generate rule for group
    print ";; Rules for elt group `$group'\n\n";
    my @elements = split /\s+/, $el_string;
    my @all = @elements;
    exists $added_alternatives{$group} and
      push @all,split /\s+/, $added_alternatives{$group};
    my $r="(/! " . join(" ", map nt_name_of($_), @all) . ")";
    if ($group !~ /^-/) {
      rule($group, $r);
      print "\n";
    }

    # generate rules for elts contained in group
    for my $element (@elements) {
      my $c = substr($element, 0, 1);
      $c eq "." and single_elt($element);
      $c eq "[" || $c eq "(" and double_elt($element);
    }
  }
}

sub nt_name_of {
  my $in = shift;
  $in =~ /\.(\w+)/ and return $1."_tag";
  $in =~ /[\[\(](\w+)/ and return $1."_elt";
  return $in;
}

sub single_elt {
  my $elt_spec = shift;
  my $elt = substr($elt_spec, 1);
  add_elt($elt);
  my $nt_name = nt_name_of($elt_spec);
  rule($nt_name, "(\$ !HTML-OPEN os \"$elt\" os attlist !CLOSE)");
  print "\n";
}

sub double_elt {
  my ($elt, $nt_name) = @_;
  my $must_open  = substr($elt, 0, 1) eq "[";
  my $must_close = substr($elt, -1) eq "]";
  defined $nt_name or $nt_name = nt_name_of($elt);
  $elt = substr($elt, 1, -1); 
  add_elt($elt);
  my ($open_tag, $close_tag) = ($elt."_open_tag", $elt."_close_tag");
  if ($must_open) {
    my $conts = $contents{$elt};
    defined $conts or die "Contents for $elt undefined.\n";
    my $open_seq  = $must_open  ? $open_tag  : "(?! $open_tag)";
    my $close_seq = $must_close ? $close_tag : "(?! $close_tag)";
    rule($nt_name, "(\$ $open_seq $conts $close_seq)");
  }
  rule($open_tag, "(\$ !HTML-OPEN os \"$elt\" os attlist !CLOSE)");
  rule($close_tag, "(\$ !HTML-OPEN os \"/\" os \"$elt\" os !CLOSE)");
  print "\n";
}

sub add_elt {
  my $elt = shift;
  $ELTS{$elt}++;
  $ELTS{$elt}==1 or die "Creating element `$elt' more than once!\n";
}
  
sub rule {
  my ($lhs, $rhs) = @_;
  printf "(%-20s%s)\n", $lhs, $rhs;
}


sub complete {
  my %contents = @_;
  while (my ($key, $val) = each %contents) {
    complete_contents_rec(\%contents, $key, $val);
  }
  return %contents;
}

sub complete_contents_rec {
  my ($c_ref, $group, $cont) = @_;
  if (!exists $elts{$group}) {
    exists $c_ref->{$group} or $c_ref->{$group}=$cont;
  } else {
    for my $new_group (split /\s+/, $elts{$group}) {
      my ($name, $elt);
      if ($new_group =~ /[\[\(.](\w+)/) {
	($name, $elt) = ($1, 1);
      } else {
	$name = $new_group;
      }
      if (!exists $c_ref->{$name}) {
	$c_ref->{$name} = $cont;
	$elt or complete_contents_rec($c_ref, $new_group, $cont);
      }
    }
  }
}

sub prologue {
  print <<'PROLOGUE';
(if (not (defined? 'basics))
    (load "basics.scm"))

(demand "make-grammar-manually.scm")

(define html-grammar-pre '(
(html_document        ($ pre_rubbish (?! ($ doctype otc)) html_elt 
			 post_rubbish))
(doctype              ($ !SGML-OPEN "DOCTYPE" !SPACE "HTML" !SPACE "PUBLIC"
                         !SPACE (* ($ !WORD os)) !CLOSE))
(attlist              (*! ($ !WORD os)))
(head_elt             ($ (/! head_open_tag isindex_tag head_misc)
                         otc (*! ($ (/! isindex_tag head_misc) otc))
                         (?! head_close_tag)))
(body_elt             ($ (/! block inline body_open_tag) otc 
			 (*! (/! block inline)) (?! body_close_tag)))
(form_elt             (/! form_open_tag form_close_tag))
(font_elt             (/! font_open_tag font_close_tag))
(implicit_tbody       (*! ($ tr_elt otc)))
(tr_elt               ($ (/! tr_open_tag td_elt) otc
		         (*! ($ (/! th_elt td_elt) otc))
                         (?! tr_close_tag)))
(td_content           (/! block inline))
(td_otc               ($ otc))
(td_elt               ($ (/! td_open_tag td_content)
		         td_otc (*! ($ td_content td_otc))
                         (?! td_close_tag)))
(in_anchor            (*! (/! fontstyle phrase special formctrl 
                              ins_elt del_elt tc form_elt)))
(os                   (? !SPACE))
(otc                  (*! (/! sgml-elt !TEXT)))
(tc                   ($ (/! sgml-elt !TEXT) (*! (/! sgml-elt !TEXT))))
(sgml-elt             ($ !SGML-OPEN (*! (/! !TEXT !SPACE !COMMENT)) !CLOSE))
(flow_rubbish         (*! ($ (/! block inline) otc)))
(pre_rubbish          (*! (/! tc head_elt)))
(post_rubbish         otc)

PROLOGUE
}

sub epilogue {
  print <<'EPILOGUE';
))

(define html-grammar (make-grammar-manually html-grammar-pre))
EPILOGUE
}
