### ----------------------------------------------------
### -- LibXML::Class
### -- Licenses: Artistic-2.0
### -- Authors: Vadim Belman
### -- File: t/200-pml-parser.rakutest
### ----------------------------------------------------
use v6.e.PREVIEW;
use Test::Async;

use LibXML;
use LibXML::Document;
use LibXML::Class;
use LibXML::Class::Config :types;
use LibXML::Class::Document;

plan 7;

# !!! Please, note, this is just a test/example and it doesn't implement full schema spec and is not intended to !!!
# Here we have a minimal subset sufficient to parse the sample.

subset XSLimit of Numeric where UInt:D | Inf;
enum XSUse (:XSUseOptional<optional>, :XSUseProhibited<prohibited>, :XSUseRequired<required>);
enum XSProcContent (:XSPCLax<lax>, :XSPCSkip<skip>, :XSPCStrict<strict>);

class XSGroup {...}
class XSSequence {...}
class XSSchema {...}

role XSBase is xml-element {
    has Str $.text is xml-text(:trim);
}

role XSNamed is xml-element {
    has Str $.name is xml-attribute;
}

role XSTyped is xml-element {
    has Str $.type is xml-attribute;
}

role XSReferencing is xml-element {
    has Str $.ref is xml-attribute;
}

role XSSingleSequence is xml-element {
    has XSSequence $.sequence is xml-element;
}

role XSMinMax[$min-default = 1, $max-default = 1] is xml-element {
    my sub serialize-limit(Numeric:D $limit) { $limit == Inf ?? 'unbounded' !! .Str }
    my sub deserialize-limit(Str:D $val) {
        $val eq 'unbounded' ?? Inf !! $val.Int
    }
    has XSLimit $.max-occurs is xml-attribute( 'maxOccurs',
                                               :serializer(&serialize-limit),
                                               :deserializer(&deserialize-limit) ) = $max-default;
    has UInt:D $.min-occurs is xml-attribute<minOccurs> = $min-default;
}

class XSDoc is LibXML::Class::Document {
    has %.registry;

    method register-named(XSNamed:D $node) {
        %!registry{$node.name}.push: $node;
    }
}

class XSConfig is LibXML::Class::Config {
    method document-class { XSDoc }
}

class XSImport is xml-element(<import>) does XSBase {
    has Str:D $.schema-location is required is xml-attribute<schemaLocation>;
    has Str:D $.namespace is required is xml-attribute;
}

class XSRestriction is xml-element('restriction') does XSBase {
    has Str:D $.base is required is xml-attribute;
    has Int $.min-inclusive is xml-element('minInclusive', :value-attr<value>);
    has Int $.max-inclusive is xml-element('maxInclusive', :value-attr<value>);
    has Int $.max-exclusive is xml-element('maxExclusive', :value-attr<value>);
    has Str:D @.enumeration is xml-element(:value-attr<value>);
}

class XSSimpleType is xml-element('simpleType') does XSNamed does XSBase {
    has XSRestriction $.restriction is xml-element;
    has Str:D @.enumeration is xml-element(:value-attr<value>);
    has Set $.union is xml-element( :serializer({ $^set.keys.join(" ") }),
                                    :deserializer({ .getAttribute('memberTypes').Str.split(/\s+/).Set }));

    submethod TWEAK {
        self.xml-document.register-named(self);
    }
}

class XSAttribute is xml-element<attribute> does XSNamed does XSTyped does XSReferencing does XSBase {
    has XSUse:D $.use is xml-attribute = XSUseOptional;
    has Str $.default is xml-attribute;
}

class XSElement is xml-element<element> does XSNamed does XSTyped does XSMinMax does XSReferencing does XSBase {}

class XSChoice is xml-element(<choice>, :sequence(XSElement)) does XSMinMax does XSBase {}

class XSAttributeGroup
    is xml-element('attributeGroup', :sequence(XSAttribute))
    does XSNamed does XSReferencing does XSBase {}

class XSAny is xml-element('any') does XSMinMax does XSBase {
    has XSProcContent $.process-contents is xml-attribute<processContents>;
}

class XSSequence is xml-element(<sequence>, :sequence(XSElement, XSChoice, XSGroup, XSAny)) does XSMinMax does XSBase {}

class XSGroup is xml-element(<group>, :sequence(XSChoice))
    does XSNamed
    does XSMinMax
    does XSReferencing
    does XSSingleSequence
    does XSBase {}

class XSComplexType is xml-element('complexType', :sequence(XSAttribute, XSAttributeGroup))
    does XSNamed
    does XSSingleSequence
    does XSBase
{
    has XSChoice $.choice is xml-element;

    submethod TWEAK {
        self.xml-document.register-named(self);
    }
}

class XSSchema
    is xml-element( 'schema',
                    :ns( 'http://purl.oclc.org/ooxml/presentationml/main', :xsd,
                        :xsd<http://www.w3.org/2001/XMLSchema>,
                        :p<http://purl.oclc.org/ooxml/presentationml/main>,
                        :a<http://purl.oclc.org/ooxml/drawingml/main>,
                        :r<http://purl.oclc.org/ooxml/officeDocument/relationships>,
                        :s<http://purl.oclc.org/ooxml/officeDocument/sharedTypes> ),
                    :sequence(XSElement, XSSimpleType, XSComplexType, XSAttributeGroup, XSSequence, XSGroup) )
    does XSBase
{
    has Str:D $.element-form-default is required is xml-attribute('elementFormDefault');
    has Str:D $.target-namespace is required is xml-attribute('targetNamespace');
    has XSImport:D @.import is xml-element;
}

my $sample = $?FILE.IO.parent.add('samples/pml.xsd').IO;
my $config = XSConfig.new: :severity(WARN), :derive(:element);
my $schema := XSSchema.from-xml: $sample.slurp(:close), :$config;
my LibXML::Element:D $xml-root = $schema.xml-document.libxml-document.documentElement;

is $schema.elems, 226, "number of schema declarations imported";

subtest "Schema Imports" => {
    plan 4;

    is $schema.import.elems, 3, "all 'import' records";
    my $import = $schema.import[0];
    isa-ok $import, XSImport, "first 'import' record type";
    is $import.namespace, "http://purl.oclc.org/ooxml/officeDocument/relationships", "'import' namespace";
    is $import.schema-location, "shared-relationshipReference.xsd", "'import' schema location";
}

subtest "First Declaration" => {
    plan 4;
    my $first = $schema.head;
    isa-ok $first, XSSimpleType, "first schema declaration is a simple type";
    is $first.name, "ST_TransitionSideDirectionType", "declaration name";
    ok $first.restriction.defined, "it has a restriction";
    cmp-deeply $first.restriction.enumeration, <l u r d>, "restriction enumeration values";
}

subtest "Cloning" => {
    plan 10;
    # Testing .clone with real sample should be even more reliable.

    my $stype = $schema[1]; # $schema[0] was used in the previous test.

    nok $stype.xml-has-restriction, "lazy attribute is not initialized yet";
    my $clone1 = $stype.clone;
    nok $clone1.xml-has-restriction, "clone's lazy attribute is uninitialized too";
    ok $stype.restriction.defined, "attribute now has a value";
    ok $stype.xml-has-restriction, "attribute initialization flag is raised";

    my $clone2 = $stype.clone;
    ok $clone2.xml-has-restriction, "second clone also has the attribute as initialized";
    cmp-ok $clone2.restriction, '===', $stype.restriction, "the clone has the same value in the attribute";

    nok $clone1.xml-has-restriction, "the first clone's attribute is still unitialized";
    ok $clone1.restriction.defined, "the first clone attribute now has a value";
    ok $clone1.xml-has-restriction, "the first clone attribute is marked as initialized";
    nok $clone1.restriction === $stype.restriction, "the first clone attribute value obtained independently";
}

subtest "Deserializations registry and search" => {

    plan 13;

    my $first = $schema.head;
    my $doc = $schema.xml-document;

    # Rely on the deserializations done in the previous subtest
    cmp-deeply
        $doc.deserializations($xml-root[7][1]).head,
        $first.restriction,
        "restriction enumeration deserialization is searchable on the document";

    nok $doc.has-deserialization($xml-root[*-4]), "registry entry is missing for undeserialized yet XML node";

    my $ds = $doc.find-deserializations($xml-root[*-4][1][5]);

    nok $doc.has-deserialization($xml-root[*-4]), "registry entry is not there yet immediately after the search";
    is $ds.elems, 1, "search over a undeserialized sequence item came up with a result";

    my $e = $ds.head;

    # This test can only sit here because $ds is a lazy sequence. Therefore $e is only deserialized when picked up.
    ok $doc.has-deserialization($xml-root[*-4]), "registry entry exists after the element is deserialized";

    subtest "found item properties", {
        plan 7;
        isa-ok $e, XSElement, "class";
        is $e.name, "outlineViewPr", ".name";
        is $e.type, "CT_OutlineViewProperties", ".type";
        is $e.min-occurs, 0, ".min-occurs";
        is $e.max-occurs, 1, ".max-occurs";
        nok $e.ref.defined, "has no .ref";
        nok $e.text.defined, "has no .text";
    }

    subtest "cloning" => {
        plan 4;

        my $ce = $e.clone;
        cmp-deeply $ce, $e, "element cloned successfully";
        ok $ce.xml-id !== $e.xml-id, "the clone and the original has different xml-id";

        $ds = $doc.find-deserializations($xml-root[*-4][1][5]).cache;
        is $ds.elems, 2, "search over the same sequence item comes up with two results now";
        cmp-ok $ds.map(*.xml-id).Set, '==', ($e.xml-id, $ce.xml-id).Set, "search finds both the original and cloned";
    }

    # Similar cases are tested in 150-find.rakutest, but here we have namespaces and better ensure they do not influence
    # the search.
    subtest "search by selected element" => {
        plan 3;

        $ds = $schema.xml-findnodes(q«//xsd:enumeration[@value = 'series']»).cache;
        is $ds.elems, 2, "all elements with the same attribute value are found";
        # But we are only intersted in the first one.
        cmp-deeply $ds.List, ("series" xx 2).List, "search by a value element finds the right values";
        is $schema.xml-findnodes(q«//xsd:enumeration[@value = 'series']»).head, "series",
            "repeating search over the same value element";
    }

    subtest "search by XML attribute" => {
        plan 2;

        my $attr-value = "CT_SlideSorterViewProperties";
        $ds = $schema.xml-findnodes(qq«//*[@name = "$attr-value"]/@name»).cache;

        is $ds.elems, 1, "search by XML attribute comes up with single value";
        is $ds.head, $attr-value, "found the expected value";
    }

    subtest "search by a text node" => {
        plan 3;

        # Pick a text node and make sure we can search over it too.
        my $text-node = $xml-root.findnodes(q«//xsd:enumeration[@value = 'series']»).head.parent[2];
        isa-ok $text-node, LibXML::Text, "control: it is a text node";
        $ds = $doc.find-deserializations($text-node).cache;
        is $ds.elems, 1, "a text node maps into single value";
        # Our xml-text attribute is using :trim resulting in an empty string for any series of new lines.
        is $ds.head, "", "found text node value";
    }

    subtest "search by a sequence item attribute" => {
        plan 2;

        my $attr-value = "subTnLst";
        my $seq-child-attr = $xml-root.findnodes(qq«//*[@name = "$attr-value"]/@name»).head;
        $ds = $doc.find-deserializations($seq-child-attr).cache;
        is $ds.elems, 1, "search comes up with the only result";
        is $ds.head, $attr-value, "found expected attribute value";
    }

    subtest "search by s sequence item element" => {
        plan 5;

        my $seq-child-elem = $xml-root.findnodes(q«//*[@name = "xfrmType"]»).head;
        $ds = $doc.find-deserializations($seq-child-elem).cache;
        is $ds.elems, 1, "search came up with exactly one result";
        my $item = $ds.head;

        isa-ok $item, XSAttribute, "item class";
        is $item.name, "xfrmType", "item name";
        is $item.type, "ST_TLBehaviorTransformType", "item type";
        is $item.use, "optional", "item use";
    }

    subtest "search by multiple elements" => {
        plan 4;

        my $items = $xml-root.findnodes(q«//*[@type = "ST_Direction"]»);
        $ds = $doc.find-deserializations($items).cache;
        is $ds.elems, $items.elems, "all matching elements found";
        cmp-ok $ds.all, '~~', XSAttribute, "all elements class";
        cmp-ok $ds.map({ .type }).all, '~~', 'ST_Direction', "all items has the same .type";
        cmp-deeply $ds.map(*.name).List, <dir orient orient orient>, "item names";
    }
}

constant CT-NAME = 'CT_TLIterateIntervalTime';

subtest "Custom Document Class" => {
    plan 4;
    # Here we basically test three things: custom config class, custom document class, and the actual laziness of
    # the sequence since XSComplexType and XSSimpleType are only registering themselves when deserialized.

    isa-ok $schema.xml-document, XSDoc, "schema document class";

    nok $schema.xml-document.registry{CT-NAME}:exists, "sequence item hasn't been referenced yet";

    for $schema<> -> $node {
        if $node ~~ XSNamed && $node.name eq CT-NAME {
            ok "found particular sequence item";
            last;
        }
    }

    ok $schema.xml-document.registry{CT-NAME}:exists, "the item has been referenced";
}

subtest "Deserializing into enum" => {
    plan 4;

    # The previous test has pulled in the node, so we can see it on the custom registry.
    my $ct-node = $schema.xml-document.registry{CT-NAME}.head;

    ok $ct-node.defined, "complexType node found on the custom registry";
    is $ct-node.elems, 1, "the node has exactly one item as a sequence";
    my $attr = $ct-node.head;

    isa-ok $attr, XSAttribute, "the item is attribute declaration";
    is $attr.use, XSUseRequired, "the attribute is 'required'";
}

sub dump-node(LibXML::Class::XMLObject:D $elem, :$level is copy = 0) {
    my $pfx = "  " x $level;
    diag $pfx, $elem.^name,
        |($elem.?name
            andthen " $_"
            orelse ($elem.?ref andthen "ref=$_")),
        ($elem ~~ XSAny ?? " process contents: " ~ $elem.process-contents !! ""),
        " ", $elem.xml-backing.nodePath;
    ++$level;

    if $elem ~~ XSSingleSequence {
        dump-node($_, :$level) with $elem.sequence;
    }
    if $elem ~~ XSComplexType {
        dump-node($_, :$level) with $elem.choice;
    }

    if $elem ~~ LibXML::Class::XMLSequential {
        for $elem<> -> $entry {
            dump-node($entry, :$level);
        }
    }
}

#dump-node($schema);

done-testing;


