view release on metacpan or  search on metacpan

htmlgen/FunctionalPerl/Htmlgen/Toc.pm  view on Meta::CPAN

#
# Copyright (c) 2014-2019 Christian Jaeger, copying@christianjaeger.ch
#
# This is free software, offered under either the same terms as perl 5
# or the terms of the Artistic License version 2 or the terms of the
# MIT License (Expat version). See the file COPYING.md that came
# bundled with this file.
#

=head1 NAME

FunctionalPerl::Htmlgen::Toc - building a table of contents

=head1 SYNOPSIS

=head1 DESCRIPTION

Expands this syntax in a PXML document:

<with_toc> <h2>..</h2> <h3>..</h3>.. <h2>..</h2> </with_toc>

into a table of contents and then the original contents but with
numbering added to the hX section headers.

=head1 SEE ALSO

This is a L<FunctionalPerl::Htmlgen::PXMLMapper>

=head1 NOTE

This is alpha software! Read the status section in the package README
or on the L<website|http://functional-perl.org/>.

=cut

package FunctionalPerl::Htmlgen::Toc;

use strict;
use warnings;
use warnings FATAL => 'uninitialized';
use experimental "signatures";

use Sub::Call::Tail;

use FP::StrictList;
use FP::List;
use Chj::TEST;
use PXML::XHTML ":all";
use FP::Stream qw(stream_mixed_state_fold_right);
use PXML ":all";
use FP::Predicates qw(is_natural);

sub rindices_numberstring($rindices) {
    is_null($rindices)
        ? ""
        : $rindices->reverse->map(sub($i) {"$i."})->strings_join("") . " "
}

TEST { rindices_numberstring(list()) } "";
TEST { rindices_numberstring(list(2, 1)) } "1.2. ";

package FunctionalPerl::Htmlgen::Toc::TocNodeBase {
    use FP::StrictList;
    use FP::Predicates;
    use FP::List;
    use PXML::XHTML ":all";

    use FP::Struct [[\&is_strictlist, "subnodes"]];

    sub subnodes_length($self) {
        $self->subnodes->length
    }

    sub subnodes_add ($self, $node) {
        is_instance_of $node, "FunctionalPerl::Htmlgen::Toc::TocNode"
            or die "wrong type";

        # (^ XX so poor, neither do I have a TypedList yet, nor the
        # syntax to add it to the method declaration)
        $self->subnodes_update(sub($l) { cons $node, $l })
    }

    sub subnodes_head_update ($self, $fn) {
        my $ss = $self->subnodes;
        if (is_null $ss) {
            die "skipped level"    ## nicer message and all?
        } else {
            $self->subnodes_set(cons(&$fn($ss->first), $ss->rest))
        }
    }

    sub level_add ($self, $levelsdown, $node) {
        is_natural $levelsdown or die "wrong type: $levelsdown";
        if ($levelsdown > 1) {
            $self->subnodes_head_update(
                sub($subnode) {
                    $subnode->level_add($levelsdown - 1, $node)
                }
            )
        } else {
            $self->subnodes_add($node)
        }
    }

    # just for debugging? $indices is a list of 1-based indices
    sub ref ($self, $indices) {
        if (is_null $indices) {
            $self
        } else {
            my ($i, $indices1) = $indices->first_and_rest;
            my $subnodes = $self->subnodes;
            $subnodes->ref($subnodes->length - $i)->ref($indices1)
        }
    }

    # used during document mapping (while the toc is collected)
    sub numberstring($self) {
        my $ss  = $self->subnodes;
        my $len = $ss->length;

        # the first is the one that was added last
        $len ? $len . "." . $ss->first->numberstring : "";

        # (O(n^2) complexity)
    }

    # build the TOC html. Need to get the numberstring differently
    # now.
    sub html_with_parents ($self, $rindices) {
        my $maybe_name = $self->name;
        my $shown      = [
            FunctionalPerl::Htmlgen::Toc::rindices_numberstring($rindices),
            $self->header_pxml_for_toc
        ];
        DIR(
            { class => "toc" },
            (
                defined $maybe_name
                ? A({ href => "#" . $maybe_name }, $shown)
                : $shown
            ),
            $self->subnodes->array__reverse__map_with_length(
                sub ($node, $num) {
                    LI($node->html_with_parents(cons $num, $rindices))
                }
            )
        )
    }

    _END_
}

package FunctionalPerl::Htmlgen::Toc::TocNode {
    use FP::Predicates "is_string";
    use PXML "is_pxml_element";
    use FP::List;

    use FP::Struct [
        [\&is_string,       "name"],    # as used in the <a name="">
                                        # already in the document
        [\&is_pxml_element, "header"]
        ],
        "FunctionalPerl::Htmlgen::Toc::TocNodeBase";

    sub header_pxml_for_toc($self) {

        # XX keep some formatting?
        $self->header->text
    }

    _END_
}

package FunctionalPerl::Htmlgen::Toc::TocRootNode {
    use FP::List;
    use PXML::XHTML ":all";

    use FP::Struct ["header_pxml_for_toc"],
        "FunctionalPerl::Htmlgen::Toc::TocNodeBase";

    sub name($self) {undef}

    sub html($self) {
        DIV({ class => "toc_box" }, $self->html_with_parents(null))
    }

    _END__
}

our $empty_toc = FunctionalPerl::Htmlgen::Toc::TocRootNode->new(strictnull,
    H3({ class => "toc_title" }, "Contents"));

sub tocnode ($name, $header) {
    FunctionalPerl::Htmlgen::Toc::TocNode->new(strictnull, $name, $header);
}

our $ttoc;
TEST {
    my $t1  = $empty_toc->level_add(1, tocnode("a", H1("First")));
    my $t11 = $t1->level_add(2, tocnode("b", H2("Sub-First")));
    my $t2  = $t11->level_add(1, tocnode("c", H1("Second")));
    $ttoc = $t2;
    [map { $_->numberstring } $t11, $t2]
}
['1.1.', '2.'];

TEST {
    my $t_paths = list(list(1), list(2), list(1, 1));
    $t_paths->map (sub($path) { $ttoc->ref($path)->name })->array
}
[qw(a c b)];

TEST { $ttoc->html->string }
'<div class="toc_box">'
    . '<dir class="toc"><h3 class="toc_title">Contents</h3>'
    . '<li><dir class="toc"><a href="#a">1. First</a>'
    . '<li><dir class="toc"><a href="#b">1.1. Sub-First</a></dir></li>'
    . '</dir></li>'
    . '<li><dir class="toc"><a href="#c">2. Second</a></dir></li>'
    . '</dir></div>';

sub process__with_toc__body ($body, $first_level, $toc, $parents) {

    # -> (processed_body, toc)
    stream_mixed_state_fold_right(
        sub ($v, $toc, $rest) {
            if (is_pxml_element($v)) {
                if (my ($_level) = $v->name =~ /^[hH](\d+)$/s) {
                    my $level = $_level - $first_level + 1;
                    is_natural $level
                        or die "The given <with_toc> tag dictates that the "
                        . "top-most header level is '$first_level', but "
                        . "encountering <"
                        . $v->name . ">";

                    my $anchor = $parents->find(