Fix builder rules (but need to reassess XSLT transforms)

xquery version "3.1";

module namespace test = 'http://xokomola.com/xquery/origami/tests';

import module namespace o = 'http://xokomola.com/xquery/origami'
    at '../origami.xqm';

declare %unit:test function test:extract-nothing()
{
    unit:assert-equals(
        o:doc(
<x y="10"/>
, o:builder()),
        ['p', ['x', map { 'y': '10' }]],
        "No argument = identity"
    ),

    unit:assert-equals(
        o:doc(
<x y="10"/>
, o:builder(())),
        ['p', ['x', map { 'y': '10' }]],
        "Empty argument = identity"
    ),

    unit:assert-equals(
        o:doc(
<x y="10"/>
, o:builder(['y'])),
        (),
        "If no rule matches return nothing"
    )
};

declare %unit:test function test:extract-whole-document()
{
    unit:assert-equals(
        o:xml(
<x y="10"/>
, o:builder(['*'])),

<x y="10"/>
,
        "Copies every element"
    )
};

(: ISSUE: removing an element doesn't allow a handler to be added :)

declare %unit:test function test:extract-whole-document-with-holes()
{
    unit:assert-equals(
        o:doc(

                <x>
                    <c>
                        <xxx/>
                    </c>
                </x>
                <y>
                    <c>
                        <yyy/>
                    </c>
                </y>

,
            o:builder(['p', ['c', ()]])
        ),
        ["p", ["x"], ["y"]],
        "Whole document leaving out c elements"
    )
};

(:~
 : When the second argument of o:doc is not a builder it is implicitly converted
 : into one.
 :)
declare %unit:test function test:implicit-builder()
{
      unit:assert-equals(
        o:xml(o:doc(<x/>,['x'])),
        <x/>
      )
};

declare %unit:test function test:implicit-builder-multiple-root-rules()
{
      unit:assert-equals(
        o:xml(o:doc(<x/>,(['x'],['y']))),
        <x/>
      )
};

(:~
 : A context function will typecheck context arguments and return the context
 : that will be available in the template rules ($c).
 :)
declare %unit:test function test:context-function()
{
    unit:assert-equals(
        o:apply(
          o:doc(
            <x>
<y/>
</x>,
            o:builder(['p', function($n,$c) { ['foo', $c?1] }])
          ),
          [12]
        ),
        ['foo', 12],
        "One argument template"
    )

};

declare %unit:test("expected", "Q{http://xokomola.com/xquery/origami}invalid-handler")
function test:invalid-handler()
{
    unit:assert-equals(
        o:doc(
            <x>
<y/>
</x>,
            o:builder(['p', function($n,$a,$b) {1}])
        ),
        (),
        "Handlers with arity > 2 are not supported"
    )
};

declare variable $test:html :=

            <title>title</title>

                        A	B	C

                        10	20	30

item 1

item 2

item 3

item 3

item 4

item 5

item 6

item 7

item 8

    ;

declare variable $test:html-no-lists :=

            <title>title</title>

                        A	B	C

                        10	20	30

    ;

declare function test:xf($rules)
{
    o:xml(o:doc($test:html, o:builder($rules)))
};

declare %unit:test function test:copy-whole-page()
{
    unit:assert-equals(
        test:xf(['html']),
        $test:html,
        "Take the whole html document"
    )
};

declare %unit:test function test:extract-lists()
{
    unit:assert-equals(
        test:xf(
            ['ol']
        ),
        (
            $test:html//ol[@id='list-1'],
            $test:html//ol[@id='list-2'],
            $test:html//ol[@id='list-3']
        ),
        "Take all lists in order"
    ),
    unit:assert-equals(
        test:xf(
            ['div', (), ['ol']]
        ),
        ($test:html//ol[@id='list-1'], $test:html//ol[@id='list-2']),
        "Take some lists using nested rule"
    )
};

declare %unit:test function test:remove-lists()
{
    unit:assert-equals(
        test:xf(
            ['html', ['ol', ()]]
        ),
        $test:html-no-lists,
        "Remove all lists"
    )
};

(: TODO: review XPaths (have to specify / otherwise li[1] and li will have same specificity):)
declare %unit:test function test:remove-all-but-first()
{
    unit:assert-equals(
        test:xf(
            ['ol[@id="list-1"]', ['/li[1]'], ['/li', ()]]
        ),

item 1

,
        "Take first list and remove all but first item"
    )
};

declare %unit:test function test:list-handler()
{
    unit:assert-equals(
        o:xml(
            o:apply(
                o:doc(

item 1

item 2

,
                    o:builder(
                        ['ol', o:wrap(['list']),
                            ['/li[1]'], ['/li', ()]
                        ]
                    )
                )
            )
        ),
        <list>

item 1

        </list>,
        "Add list handler"
    )
};

declare variable $test:html-table :=

This is a table

          hello world!
          foobar

          bla bla
          foobar

  ;

declare function test:extract-table($rules)
{
    o:xml(
        o:apply(
            o:doc(
                $test:html-table,
                $rules
            )
        )
    )
};

declare %unit:test function test:table-extractions-1()
{
    unit:assert-equals(
        test:extract-table(['table']),
        $test:html-table//table,
        "Extract the table"
    )
};

declare %unit:test function test:table-extractions-2()
{
    unit:assert-equals(
        test:extract-table(['td|th']),
        $test:html-table//(td|th),
        "Extract the table cells (td and th) directly"
    ),

    unit:assert-equals(
        test:extract-table(['table', (), ['tr', (), ['td|th']]]),
        $test:html-table//(td|th),
        "Extract the table cells (td and th) in proper context"
    )
};

(: TODO: review XPaths (to remove attributes have to specify */@* instead of just @*) :)
declare %unit:test function test:table-extractions-3()
{
    unit:assert-equals(
        test:extract-table(['table', ['*/@*', ()]]),

                hello world!
                foobar

                bla bla
                foobar

        ,
        "Extract the table but remove all attributes"
    ),

    unit:assert-equals(
        test:extract-table(['table', ['*/@*[name(.) != "class"]', ()]]),

                hello world!
                foobar

                bla bla
                foobar

        ,
        "Extract the table but remove some attributes"
    )

};

declare %unit:test %unit:ignore function test:table-extractions-4()
{
    unit:assert-equals(
        test:extract-table((
          ['tr[th]'],
          ['tr[td]']
        )),
        $test:html-table//tr,
        "Header and data row separately (root rules are in undefined order
         so results come back in undefined order as well)"
    )
};

declare %unit:test function test:table-extractions-5()
{
    unit:assert-equals(
        test:extract-table(
          ['table', (),
            ['tr[th]'],
            ['tr[td]']
          ]),
        ($test:html-table//tr[th], $test:html-table//tr[td]),
        "The same example as in test:table-extractions-4 but worked around the issue"
    )
};

(: TODO: review XPaths (now XPaths are concatenated we cannot just specify td|th) :)
declare %unit:test function test:table-extractions-6()
{
    unit:assert-equals(
        test:extract-table(
          ['table',
            ['td',
              ['text()', ()]
            ],
            ['th',
              ['text()', ()]
            ]
          ]
        ),

        ,
        "Remove all text nodes from the table cells"
    )
};

(: TODO: review XPaths (now XPaths are concatenated we cannot just specify td|th) :)
declare %unit:test function test:table-extractions-7()
{
    unit:assert-equals(
        test:extract-table(
          ['table',
            ['th',
              ['*', (),
                ['text()']
              ]
            ],
            ['td',
              ['*', (),
                ['text()']
              ]
            ]
          ]
        ),

                hello world!
                foobar

                bla bla
                foobar

        ,
        "Clear inline markup inside the cells"
    )
};

(: TODO: review XPaths (now XPaths are concatenated we cannot just specify td|th) :)
declare %unit:test function test:table-extractions-8()
{
    unit:assert-equals(
        test:extract-table(
          ['table',
            ['tr',
              ['@*', ()],
              ['th',
                ['*', (),
                  ['text()']
                ]
              ],
              ['td',
                ['*', (),
                  ['text()']
                ]
              ]
            ]
          ]
        ),

                hello world!
                foobar

                bla bla
                foobar

        ,
        "Clear inline markup inside the cells and remove the attributes"
    )
};

xquery version "3.1";

module namespace test = 'http://xokomola.com/xquery/origami/tests';

import module namespace o = 'http://xokomola.com/xquery/origami'
    at '../origami.xqm';

declare %unit:test function test:extract-nothing()
{
    unit:assert-equals(
        o:doc(
<x y="10"/>
, o:builder()),
        ['p', ['x', map { 'y': '10' }]],
        "No argument = identity"
    ),

    unit:assert-equals(
        o:doc(
<x y="10"/>
, o:builder(())),
        ['p', ['x', map { 'y': '10' }]],
        "Empty argument = identity"
    ),

    unit:assert-equals(
        o:doc(
<x y="10"/>
, o:builder(['y'])),
        (),
        "If no rule matches return nothing"
    )
};

declare %unit:test function test:extract-whole-document()
{
    unit:assert-equals(
        o:xml(
<x y="10"/>
, o:builder(['*'])),

<x y="10"/>
,
        "Copies every element"
    )
};

(: ISSUE: removing an element doesn't allow a handler to be added :)

declare %unit:test function test:extract-whole-document-with-holes()
{
    unit:assert-equals(
        o:doc(

                <x>
                    <c>
                        <xxx/>
                    </c>
                </x>
                <y>
                    <c>
                        <yyy/>
                    </c>
                </y>

,
            o:builder(['p', ['c', ()]])
        ),
        ["p", ["x"], ["y"]],
        "Whole document leaving out c elements"
    )
};

(:~
 : When the second argument of o:doc is not a builder it is implicitly converted
 : into one.
 :)
declare %unit:test function test:implicit-builder()
{
      unit:assert-equals(
        o:xml(o:doc(<x/>,['x'])),
        <x/>
      )
};

declare %unit:test function test:implicit-builder-multiple-root-rules()
{
      unit:assert-equals(
        o:xml(o:doc(<x/>,(['x'],['y']))),
        <x/>
      )
};

(:~
 : A context function will typecheck context arguments and return the context
 : that will be available in the template rules ($c).
 :)
declare %unit:test function test:context-function()
{
    unit:assert-equals(
        o:apply(
          o:doc(
            <x>
<y/>
</x>,
            o:builder(['p', function($n,$c) { ['foo', $c?1] }])
          ),
          [12]
        ),
        ['foo', 12],
        "One argument template"
    )

};

declare %unit:test("expected", "Q{http://xokomola.com/xquery/origami}invalid-handler")
function test:invalid-handler()
{
    unit:assert-equals(
        o:doc(
            <x>
<y/>
</x>,
            o:builder(['p', function($n,$a,$b) {1}])
        ),
        (),
        "Handlers with arity > 2 are not supported"
    )
};

declare variable $test:html :=

            <title>title</title>

                        A	B	C

                        10	20	30

item 1

item 2

item 3

item 3

item 4

item 5

item 6

item 7

item 8

    ;

declare variable $test:html-no-lists :=

            <title>title</title>

                        A	B	C

                        10	20	30

    ;

declare function test:xf($rules)
{
    o:xml(o:doc($test:html, o:builder($rules)))
};

declare %unit:test function test:copy-whole-page()
{
    unit:assert-equals(
        test:xf(['html']),
        $test:html,
        "Take the whole html document"
    )
};

declare %unit:test function test:extract-lists()
{
    unit:assert-equals(
        test:xf(
            ['ol']
        ),
        (
            $test:html//ol[@id='list-1'],
            $test:html//ol[@id='list-2'],
            $test:html//ol[@id='list-3']
        ),
        "Take all lists in order"
    ),
    unit:assert-equals(
        test:xf(
            ['div', (), ['ol']]
        ),
        ($test:html//ol[@id='list-1'], $test:html//ol[@id='list-2']),
        "Take some lists using nested rule"
    )
};

declare %unit:test function test:remove-lists()
{
    unit:assert-equals(
        test:xf(
            ['html', ['ol', ()]]
        ),
        $test:html-no-lists,
        "Remove all lists"
    )
};

declare %unit:test function test:remove-all-but-first()
{
    unit:assert-equals(
        test:xf(
            ['ol[@id="list-1"]', ['li[1]'], ['li', ()]]
        ),

item 1

,
        "Take first list and remove all but first item"
    )
};

declare %unit:test function test:list-handler()
{
    unit:assert-equals(
        o:xml(
            o:apply(
                o:doc(

item 1

item 2

,
                    o:builder(
                        ['ol', o:wrap(['list']),
                            ['li[1]'], ['li', ()]
                        ]
                    )
                )
            )
        ),
        <list>

item 1

        </list>,
        "Add list handler"
    )
};

declare variable $test:html-table :=

This is a table

          hello world!
          foobar

          bla bla
          foobar

  ;

declare function test:extract-table($rules)
{
    o:xml(
        o:apply(
            o:doc(
                $test:html-table,
                $rules
            )
        )
    )
};

declare %unit:test function test:table-extractions-1()
{
    unit:assert-equals(
        test:extract-table(['table']),
        $test:html-table//table,
        "Extract the table"
    )
};

declare %unit:test function test:table-extractions-2()
{
    unit:assert-equals(
        test:extract-table(['td|th']),
        $test:html-table//(td|th),
        "Extract the table cells (td and th) directly"
    ),

    unit:assert-equals(
        test:extract-table(['table', (), ['tr', (), ['td|th']]]),
        $test:html-table//(td|th),
        "Extract the table cells (td and th) in proper context"
    )
};

declare %unit:test function test:table-extractions-3()
{
    unit:assert-equals(
        test:extract-table(['table', ['@*', ()]]),

                hello world!
                foobar

                bla bla
                foobar

        ,
        "Extract the table but remove all attributes"
    ),

    unit:assert-equals(
        test:extract-table(['table', ['@*[name(.) != "class"]', ()]]),

                hello world!
                foobar

                bla bla
                foobar

        ,
        "Extract the table but remove some attributes"
    )

};

declare %unit:test %unit:ignore function test:table-extractions-4()
{
    unit:assert-equals(
        test:extract-table((
          ['tr[th]'],
          ['tr[td]']
        )),
        $test:html-table//tr,
        "Header and data row separately (root rules are in undefined order
         so results come back in undefined order as well)"
    )
};

declare %unit:test function test:table-extractions-5()
{
    unit:assert-equals(
        test:extract-table(
          ['table', (),
            ['tr[th]'],
            ['tr[td]']
          ]),
        ($test:html-table//tr[th], $test:html-table//tr[td]),
        "The same example as in test:table-extractions-4 but worked around the issue"
    )
};

declare %unit:test function test:table-extractions-6()
{
    unit:assert-equals(
        test:extract-table(
          ['table',
            ['td|th',
              ['text()', ()]
            ]
          ]
        ),

        ,
        "Remove all text nodes from the table cells"
    )
};

declare %unit:test function test:table-extractions-7()
{
    unit:assert-equals(
        test:extract-table(
          ['table',
            ['td|th',
              ['*', (),
                ['text()']
              ]
            ]
          ]
        ),

                hello world!
                foobar

                bla bla
                foobar

        ,
        "Clear inline markup inside the cells"
    )
};

declare %unit:test function test:table-extractions-8()
{
    unit:assert-equals(
        test:extract-table(
          ['table',
            ['tr',
              ['@*', ()],
              ['td|th',
                ['*', (),
                  ['text()']
                ]
              ]
            ]
          ]
        ),

                hello world!
                foobar

                bla bla
                foobar

        ,
        "Clear inline markup inside the cells and remove the attributes"
    )
};


[bugfix] Correct XQuery Syntax

[bugfix] Correct XQuery Syntax

xquery version "3.0";

(:~
 : XQSuite - a functional test framework based on XQuery 3.0 annotations.
 : Relies on the functions util:list-functions and util:inspect-function
 : to inspect annotations. The rest is pretty much standard XQuery.
 :
 : Usage:
 :
 : <pre>
 : import module namespace test="http://exist-db.org/xquery/xqsuite" at "resource:org/exist/xquery/lib/xqsuite/xqsuite.xql";
 : import module namespace t="http://exist-db.org/xquery/test/examples" at "examples.xql";
 :
 : test:suite(util:list-functions("http://exist-db.org/xquery/test/examples"))
 : </pre>
 :
 : @author Wolfgang Meier
 :)
module namespace test="http://exist-db.org/xquery/xqsuite";

declare namespace stats="http://exist-db.org/xquery/profiling";

declare variable $test:TEST_NAMESPACE := "http://exist-db.org/xquery/xqsuite";

declare variable $test:UNKNOWN_ASSERTION := QName($test:TEST_NAMESPACE, "no-such-assertion");
declare variable $test:WRONG_ARG_COUNT := QName($test:TEST_NAMESPACE, "wrong-number-of-arguments");
declare variable $test:TYPE_ERROR := QName($test:TEST_NAMESPACE, "type-error");

(:~
 : Main entry point into the module. Takes a sequence of function items.
 : Functions with known test annotations will be evaluated and their results
 : checked against the annotations.
 :
 : @param $functions a sequence of function items
 : @return an XML report (in xUnit format)
 :)
declare function test:suite($functions as function(*)+) {
    let $modules := test:distinct-modules($functions)
    return
        <testsuites>
        {
            (: Run tests for each module in turn :)
            for $module in $modules
            let $modFunctions := filter($functions, function($func) {
                    namespace-uri-from-QName(function-name($func)) = $module
                })
            let $setup := test:call-func-with-annotation($modFunctions, "setUp")
            let $result :=
                if (empty($setup) or $setup/self::ok) then
                    let $startTime := util:system-time()
                    let $results :=
                        test:function-by-annotation($modFunctions, "assert", test:run-tests#2)
                    let $elapsed :=
                        util:system-time() - $startTime
                    return
                        <testsuite package="{$module}" timestamp="{util:system-dateTime()}"
                            failures="{count($results/failure)}" pending="{count($results/pending)}"
                            tests="{count($results)}" time="{$elapsed}">
                            { $results }
                        </testsuite>
                else
                    <testsuite package="{$module}" timestamp="{util:system-dateTime()}"
                        errors="{count($functions)}">
                        {$setup/string()}
                    </testsuite>
            return
                ($result, test:call-func-with-annotation($modFunctions, "tearDown"))[1]
        }
        </testsuites>
};

(:~
 : Find functions having the given annotation and call the callback function.
 :)
declare %private function test:function-by-annotation($functions as function(*)+, $annot as xs:string,
    $callback as function(function(*), element(function)) as item()*) {
    for $function in $functions
    let $meta := util:inspect-function($function)
    where $meta/annotation[@namespace = $test:TEST_NAMESPACE][matches(@name, ":" || $annot)]
    return
        $callback($function, $meta)
};

(:~
 : Return the namespace URI of all distinct modules in the input set.
 :)
declare %private function test:distinct-modules($functions as function(*)+) as xs:string+ {
    distinct-values(
        for $func in $functions
        return
            namespace-uri-from-QName(function-name($func))
    )
};

(:~
 : Find functions having the specified annotation and call them,
 : return <ok/> upon success, an error description otherwise.
 : Used for setUp and tearDown.
 :)
declare %private function test:call-func-with-annotation($functions as function(*)+, $annot as xs:string) as element()? {
    test:function-by-annotation($functions, $annot, function($func, $meta) {
        try {
            (<ok/>, $func())[1]
        } catch * {
            <system-err>{$err:description}</system-err>
        }
    })
};

(:~
 : Calls the test function one or more times, depending on the number of
 : %args() annotations found. Each %arg annotation triggers one test run
 : using the supplied parameters.
 :)
declare %private function test:run-tests($func as function(*), $meta as element(function)) {
    if($meta/annotation[ends-with(@name,  ":pending")])then
      test:print-result($meta, (), <report>{
        element pending {
          $meta/annotation[ends-with(@name,  ":pending")]/value ! text()
        }
      }</report>)
    else
      let $argsAnnot := $meta/annotation[matches(@name, ":args?")][not(preceding-sibling::annotation[1][matches(@name, ":args?")])]
      return
          if ($argsAnnot) then
              $argsAnnot ! test:test($func, $meta, .)
          else
              test:test($func, $meta, ())
};

(:~
 : The main function for running a single test. Executes the test function
 : and compares the result against each assertXXX annotation.
 :)
declare %private function test:test($func as function(*), $meta as element(function), $firstArg as element(annotation)?) {
    let $args := test:get-run-args($firstArg)
    let $assertions := test:get-assertions($meta, $firstArg)
    let $assertError := $assertions[contains(@name, ":assertError")]
    return
        if (exists($assertions)) then
            try {
                let $result := test:call-test($func, $meta, $args)
                let $assertResult := test:check-assertions($assertions, $result)
                return
                    if ($assertError) then
                        test:print-result($meta, $result,
                            <report>
                                <failure message="Expected error {$assertError/value/string()}."
                                    type="failure-error-code-1"/>
                            </report>
                        )
                    else
                        test:print-result($meta, $result, $assertResult)
            } catch * {
                if ($assertError) then
                    if ($assertError/value and not(contains($err:code, $assertError/value/string())
                        or matches($err:description, $assertError/value/string())))then
                        test:print-result($meta, (),
                            <report>
                                <failure message="Expected error {$assertError/value/string()}, got: {$err:code} {$err:description}"
                                    type="failure-error-code-1"/>
                            </report>
                        )
                    else
                        test:print-result($meta, (), ())
                else
                    test:print-result($meta, (),
                        <report>
                            <error type="{$err:code}" message="{$err:description}"/>
                        </report>
                    )
            }
        else
            ()
};

declare function test:enable-tracing($meta as element(function)) {
    let $statsAnno := $meta//annotation[contains(@name, ":stats")]
    return
        if (exists($statsAnno)) then (
            system:clear-trace(),
            system:enable-tracing(true(), false()),
            true()
        ) else
            false()
};

(:~
 : Get all %assertXXX annotations of the function. If %args is used multiple times,
 : assertions apply to the result of running the function with the parameters given
 : in the preceding %args.
 :)
declare %private function test:get-assertions($meta as element(function), $firstArg as element(annotation)?) {
    if ($firstArg) then
        let $nextBlock :=
            $firstArg/following-sibling::annotation[matches(@name, ":args?")]
                [preceding-sibling::annotation[1][contains(@name, ":assert")]][1]
        return
            if ($nextBlock) then
                $firstArg/following-sibling::annotation[contains(@name, ":assert")]
                intersect
                $nextBlock/preceding-sibling::annotation[contains(@name, ":assert")]
            else
                $firstArg/following-sibling::annotation[contains(@name, ":assert")]
    else
        $meta/annotation[contains(@name, ":assert")]
};

(:~
 : Collect %test:arg and %test:args for the current run.
 :)
declare %private function test:get-run-args($firstArg as element(annotation)?) {
    if ($firstArg) then
        let $nextBlock :=
            $firstArg/following-sibling::annotation[matches(@name, ":args?")]
                [preceding-sibling::annotation[1][contains(@name, ":assert")]][1]
        return (
            $firstArg,
            if ($nextBlock) then
                $firstArg/following-sibling::annotation[matches(@name, ":args?")]
                intersect
                $nextBlock/preceding-sibling::annotation
            else
                $firstArg/following-sibling::annotation[matches(@name, ":args?")]
        )
    else
        ()
};

(:~
 : Map any arguments from the %args or %arg annotations into function parameters and evaluate
 : the resulting function.
 :)
declare %private function test:call-test($func as function(*), $meta as element(function), $args as element(annotation)*) {
    let $funArgs :=
        if ($args[1]/@name = "test:args") then
            test:map-arguments($args/value/string(), $meta/argument)
        else
            test:map-named-arguments($meta/argument, $args)
    return
        test:apply($func, $meta, $funArgs)
};

(:~
 : Map a sequence of %arg annotations to named function parameters.
 :)
declare %private function test:map-named-arguments($funcArgs as element(argument)*, $testArgs as element(annotation)*) {
    let $mappedArgs :=
        for $arg in $funcArgs
        let $argName := $arg/@var/string()
        let $testArg := $testArgs[value[1] = $argName]
        return
            if (empty($testArg)) then
                error($test:WRONG_ARG_COUNT, "No matching %test:arg found for parameter " || $argName)
            else
                test:map-named-argument(subsequence($testArg/value, 2), $arg)
    return
        if (count($mappedArgs) != count($funcArgs)) then
            error(
                $test:WRONG_ARG_COUNT,
                "The number of arguments specified via test:arg must match the arguments of the function to test"
            )
        else
            $mappedArgs
};

declare %private function test:map-named-argument($testArgs as element(value)*, $funcArg as element(argument)) {
    let $data :=
        try {
            test:cast($testArgs, $funcArg)
        } catch * {
            error($test:TYPE_ERROR, "Failed to cast annotation arguments to required target type " || $funcArg/@type)
        }
    return
        (: If we need to return a sequence of values, enclose them into a closure function :)
        function() { $data }
};

(:~
 : For %args: transform each annotation parameter into the type required for the function parameter.
 :)
declare %private function test:map-arguments($testArgs as xs:string*, $funcArgs as element(argument)*) {
    if (exists($testArgs)) then
        if (count($testArgs) != count($funcArgs)) then
            error(
                $test:WRONG_ARG_COUNT,
                "The number of arguments specified in test:args must match the arguments of the function to test"
            )
        else
            map-pairs(function($targ as xs:string, $farg as element(argument)) {
                let $data := test:cast($targ, $farg)
                return
                    function() { $data }
            }, $testArgs, $funcArgs)
    else
        ()
};

declare %private function test:cast($targs as xs:string*, $farg as element(argument)) {
    for $targ in $targs
    return
        switch (string($farg/@type))
            case "xs:string" return
                string($targ)
            case "xs:integer" case "xs:int" return
                xs:integer($targ)
            case "xs:decimal" return
                xs:decimal($targ)
            case "xs:float" case "xs:double" return
                xs:double($targ)
            case "xs:date" return
                xs:date($targ)
            case "xs:dateTime" return
                xs:dateTime($targ)
            case "xs:time" return
                xs:time($targ)
            case "element()" return
                util:parse($targ)/*
            case "text()" return
                text { string($targ) }
            default return
                $targ
};

declare function test:apply($func as function(*), $meta as element(function), $args as item()*) {
    let $trace := test:enable-tracing($meta)
    let $userAnno := $meta/annotation[contains(@name, ":user")]
    let $result :=
        if ($userAnno) then
            let $user := $userAnno/value[1]/string()
            let $pass := $userAnno/value[2]/string()
            return
                system:as-user($user, $pass, test:apply($func, $args))
        else
            test:apply($func, $args)
    return
        if ($trace) then
            (: Get trace output and filter out stats :)
            let $traceOutput :=
                (system:trace(), system:clear-trace(), system:enable-tracing(false()))
            return
                element { node-name($traceOutput) } {
                    $traceOutput/stats:*[not(starts-with(@source, "org.exist") or contains(@source, "xqsuite.xql"))]
                }
        else
            $result
};

(:~
 : Call the given function with parameters taken from $args.
 :)
declare %private function test:apply($func as function(*), $args as item()*) {
    switch (count($args))
        case 0 return
            $func()
        case 1 return
            $func($args[1]())
        case 2 return
            $func($args[1](), $args[2]())
        case 3 return
            $func($args[1](), $args[2](), $args[3]())
        case 4 return
            $func($args[1](), $args[2](), $args[3](), $args[4]())
        case 5 return
            $func($args[1](), $args[2](), $args[3](), $args[4](), $args[5]())
        case 6 return
            $func($args[1](), $args[2](), $args[3](), $args[4](), $args[5](), $args[6]())
        case 7 return
            $func($args[1](), $args[2](), $args[3](), $args[4](), $args[5](), $args[6](), $args[7]())
        default return
            error($test:WRONG_ARG_COUNT, "Function takes too many arguments")
};

(:~
 : Print out evaluation results for a given test.
 :)
declare %private function test:print-result($meta as element(function), $result as item()*,
    $assertResult as element(report)*) {
    let $nameAnnot := $meta/annotation[matches(@name, ":name")]
    let $name := if ($nameAnnot) then $nameAnnot/value else replace($meta/@name, "^\w+:([^:]+)$", "$1")
    return
        <testcase name="{$name}" class="{$meta/@name}">
        {
            if (exists($assertResult)) then
                ($assertResult[failure] | $assertResult)[1]/*
            else
                ()
        }
        </testcase>
};

(:~
 : Check the function's return value against each assertion.
 :)
declare %private function test:check-assertions($assertions as element(annotation)*, $result as item()*) as element(report)* {
    for $annotation in $assertions
    let $assert := replace($annotation/@name, "^\w+:(.*)$", "$1")
    return
        switch ($assert)
            case "assertEquals" return
                test:assertEquals($annotation/value/string(), $result)
            case "assertEqualsPermutation" return
                test:assertEqualsPermutation($annotation/value/string(), $result)
            case "assertEmpty" return
                test:assertEmpty($result)
            case "assertExists" return
                test:assertExists($result)
            case "assertTrue" return
                test:assertTrue($result)
            case "assertFalse" return
                test:assertFalse($result)
            case "assertXPath" return
                test:assertXPath($annotation, $result)
            case "assertError" return
                test:assertError($annotation/value/string(), $result)
            default return
                error($test:UNKNOWN_ASSERTION, $annotation/@name)
};

(:~
 : Check for equality of the function's result with the value in the annotation.
 : This function transforms the result to a string before checking for equality.
 :)
declare %private function test:assertEquals($values as item()*, $result as item()*) as element(report)? {
    if (exists($values)) then
        if (count($values) eq count($result)) then
            let $tests := map-pairs(test:equals#2, $values, $result)
            let $equal := every $test in $tests satisfies $test
            return
                if ($equal) then
                    ()
                else
                   <report>
                        <failure message="assertEquals failed."
                            type="failure-error-code-1">
                        { $values }
                        </failure>
                        <output>{ $result }</output>
                    </report>
        else
            <report>
                <failure message="assertEquals failed: wrong number of items returned by function. Expected: {count($values)}. Got: {count($result)}"
                    type="failure-error-code-1">
                { $values }
                </failure>
                <output>{ $result }</output>
            </report>
    else
        ()
};

(:~
 : Check for equality of the function's result with the value in the annotation.
 : This function transforms the result to a string before checking for equality.
 :)
declare %private function test:assertEqualsPermutation($values as item()*, $result as item()*) as element(report)? {
    if (exists($values)) then
        if (count($values) eq count($result)) then
            let $tests :=
                for $item in $result
                return
                    some $value in $values satisfies test:equals($item, $value)
            let $equal := every $test in $tests satisfies $test
            return
                if ($equal) then
                    ()
                else
                   <report>
                        <failure message="assertEquals failed."
                            type="failure-error-code-1">
                        { $values }
                        </failure>
                        <output>{ $result }</output>
                    </report>
        else
            <report>
                <failure message="assertEquals failed: wrong number of items returned by function. Expected: {count($values)}. Got: {count($result)}"
                    type="failure-error-code-1">
                { $values }
                </failure>
                <output>{ $result }</output>
            </report>
    else
        ()
};

declare %private function test:equals($value as item(), $result as item()) as xs:boolean {
    let $normResult :=
        typeswitch ($result)
            case node() return
                test:normalize($result)
            default return
                $result
    let $normValue := test:cast-to-type($value, $result)
    return
        typeswitch ($normResult)
            case node() return
                deep-equal($normValue, $normResult)
            default return
                $normResult eq $normValue
};

declare %private function test:normalize($nodes as node()*) {
    $nodes ! test:normalize-node(.)
};

declare %private function test:normalize-node($node as node()) {
    typeswitch ($node)
        case document-node() return
            test:normalize-node($node/*)
        case element() return
            element { node-name($node) } {
                $node/@*, for $child in $node/node() return test:normalize-node($child)
            }
        case text() return
            let $norm := normalize-space($node)
            return
                if (string-length($norm) eq 0) then () else $node
        default return
            $node
};

(:~
 : Check if the function's result is empty.
 :)
declare %private function test:assertEmpty($result as item()*) as element(report)? {
    if (empty($result)) then
        ()
    else
        <report>
            <failure message="assertEmpty failed."
                type="failure-error-code-1"/>,
            <output>{ $result }</output>
        </report>
};

(:~
 : Check if the function's result is not empty.
 :)
declare %private function test:assertExists($result as item()*) as element(report)? {
    if (exists($result)) then
        ()
    else
        <report>
            <failure message="assertExists failed."
                type="failure-error-code-1"/>,
            <output>{ $result }</output>
        </report>
};

(:~
 : Check if the function's result is true.
 :)
declare %private function test:assertTrue($result as item()*) as element(report)? {
    if ($result) then
        ()
    else
        <report>
            <failure message="assertExists failed."
                type="failure-error-code-1"/>,
            <output>{ $result }</output>
        </report>
};

(:~
 : Check if the function caused an error.
 :)
declare %private function test:assertError($value as xs:string, $result as item()*) as element(report)? {
    if ($result) then
        ()
    else
        <report>
            <failure message="assertError failed. Expected error {$value}"
                type="failure-error-code-1"/>,
            <output>{ $result }</output>
        </report>
};

(:~
 : Check if the function's result is false.
 :)
declare %private function test:assertFalse($result as item()*) as element(report)? {
    if (not($result)) then
        ()
    else
        <report>
            <failure message="assertExists failed."
                type="failure-error-code-1"/>,
            <output>{ $result }</output>
        </report>
};

(:~
 : Evaluate an arbitrary XPath expression against result. The test passes if
 : the XPath returns either true or a non-empty sequence.
 :)
declare %private function test:assertXPath($annotation as element(annotation), $output as item()*) as element(report)? {
    let $expr := $annotation/value[1]/string()
    let $result :=
        if (count($annotation/value) = 2 and boolean($annotation/value[2])) then
            util:expand($output)
        else
            $output
    let $prolog :=
        if ($result instance of element()*) then
            let $namespaces := fold-left($result/descendant-or-self::*, map:new(),
                function ($namespaces as map(*), $xml as element()) {
                    map:new(($namespaces,
                	    for $prefix in in-scope-prefixes($xml)
                	    where $prefix != "" and $prefix != "xml"
                	    return
                	        map:entry($prefix, namespace-uri-for-prefix($prefix, $xml))
                    ))
                }
            )
            return
                string-join(
                    for $prefix in map:keys($namespaces)
                    return
                        "declare namespace " || $prefix || "='" || $namespaces($prefix) || "';",
                    " "
                )
        else
            ()
    let $xr :=
        test:checkXPathResult(
            if (matches($expr, "^\s*/")) then
                util:eval($prolog || "$result" || $expr)
            else
                util:eval($prolog || $expr)
        )
    return
        if ($xr) then
            ()
        else
            <report>
                <failure message="assertXPath failed."
                    type="failure-error-code-1">{ $expr }</failure>,
                <output>{ $result }</output>
            </report>
};

declare %private function test:checkXPathResult($result as item()*) {
    if ($result instance of xs:boolean) then
        $result
    else
        exists($result)
};

declare %private function test:cast-to-type($value as item(), $result as item()) {
    typeswitch ($result)
        case node() return
            util:parse("<r>" || $value || "</r>")/r/node()
        case xs:integer return
            xs:integer($value)
        case xs:int return
            xs:int($value)
        case xs:long return
            xs:long($value)
        case xs:decimal return
            xs:decimal($value)
        case xs:double return
            xs:double($value)
        case xs:float return
            xs:float($value)
        case xs:date return
            xs:date($value)
        case xs:dateTime return
            xs:dateTime($value)
        case xs:time return
            xs:time($value)
        case xs:boolean return
            xs:boolean($value)
        case xs:anyURI return
            xs:anyURI($value)
        default return
            string($value)
};

(: Helper functions to be used by test modules :)

declare function test:mkcol($root as xs:string, $path as xs:string) as empty-sequence() {
    test:mkcol-recursive($root, tokenize($path, "/"))
};

declare %private function test:mkcol-recursive($collection, $components) as empty-sequence() {
    if (exists($components)) then
        let $newColl := concat($collection, "/", $components[1])
        return (
            xmldb:create-collection($collection, $components[1])[2],
            test:mkcol-recursive($newColl, subsequence($components, 2))
        )
    else
        ()
};

declare function test:to-html($output as element(testsuites)) {
    <div class="testresult">
    {
        $output/testsuite !
            <section>
                <h2>{@package/string()}</h2>
                <table>
                {
                    for $case in testcase
                    return
                        test:print-testcase($case)
                }
                </table>
            </section>
    }
    </div>
};

declare %private function test:print-testcase($case as element(testcase)) {
    <tr class="{if ($case/failure or $case/error) then 'fail' else 'pass'}">
        <td>{$case/@name/string()}</td>
        <td>
        {
            if ($case/failure) then
                ($case/failure/@message/string(), " Expected: ", $case/failure/text())
            else if ($case/error) then
                ($case/error/@type/string(), " ", $case/error/@message/string())
            else
                "OK"
        }
        </td>
    </tr>
};

xquery version "3.0";

(:~
 : XQSuite - a functional test framework based on XQuery 3.0 annotations.
 : Relies on the functions util:list-functions and util:inspect-function
 : to inspect annotations. The rest is pretty much standard XQuery.
 :
 : Usage:
 :
 : <pre>
 : import module namespace test="http://exist-db.org/xquery/xqsuite" at "resource:org/exist/xquery/lib/xqsuite/xqsuite.xql";
 : import module namespace t="http://exist-db.org/xquery/test/examples" at "examples.xql";
 :
 : test:suite(util:list-functions("http://exist-db.org/xquery/test/examples"))
 : </pre>
 :
 : @author Wolfgang Meier
 :)
module namespace test="http://exist-db.org/xquery/xqsuite";

declare namespace stats="http://exist-db.org/xquery/profiling";

declare variable $test:TEST_NAMESPACE := "http://exist-db.org/xquery/xqsuite";

declare variable $test:UNKNOWN_ASSERTION := QName($test:TEST_NAMESPACE, "no-such-assertion");
declare variable $test:WRONG_ARG_COUNT := QName($test:TEST_NAMESPACE, "wrong-number-of-arguments");
declare variable $test:TYPE_ERROR := QName($test:TEST_NAMESPACE, "type-error");

(:~
 : Main entry point into the module. Takes a sequence of function items.
 : Functions with known test annotations will be evaluated and their results
 : checked against the annotations.
 :
 : @param $functions a sequence of function items
 : @return an XML report (in xUnit format)
 :)
declare function test:suite($functions as function(*)+) {
    let $modules := test:distinct-modules($functions)
    return
        <testsuites>
        {
            (: Run tests for each module in turn :)
            for $module in $modules
            let $modFunctions := filter($functions, function($func) {
                    namespace-uri-from-QName(function-name($func)) = $module
                })
            let $setup := test:call-func-with-annotation($modFunctions, "setUp")
            let $result :=
                if (empty($setup) or $setup/self::ok) then
                    let $startTime := util:system-time()
                    let $results :=
                        test:function-by-annotation($modFunctions, "assert", test:run-tests#2)
                    let $elapsed :=
                        util:system-time() - $startTime
                    return
                        <testsuite package="{$module}" timestamp="{util:system-dateTime()}"
                            failures="{count($results/failure)}" pending="{count($results/pending)}"
                            tests="{count($results)}" time="{$elapsed}">
                            { $results }
                        </testsuite>
                else
                    <testsuite package="{$module}" timestamp="{util:system-dateTime()}"
                        errors="{count($functions)}">
                        {$setup/string()}
                    </testsuite>
            return
                ($result, test:call-func-with-annotation($modFunctions, "tearDown"))[1]
        }
        </testsuites>
};

(:~
 : Find functions having the given annotation and call the callback function.
 :)
declare %private function test:function-by-annotation($functions as function(*)+, $annot as xs:string,
    $callback as function(function(*), element(function)) as item()*) {
    for $function in $functions
    let $meta := util:inspect-function($function)
    where $meta/annotation[@namespace = $test:TEST_NAMESPACE][matches(@name, ":" || $annot)]
    return
        $callback($function, $meta)
};

(:~
 : Return the namespace URI of all distinct modules in the input set.
 :)
declare %private function test:distinct-modules($functions as function(*)+) as xs:string+ {
    distinct-values(
        for $func in $functions
        return
            namespace-uri-from-QName(function-name($func))
    )
};

(:~
 : Find functions having the specified annotation and call them,
 : return <ok/> upon success, an error description otherwise.
 : Used for setUp and tearDown.
 :)
declare %private function test:call-func-with-annotation($functions as function(*)+, $annot as xs:string) as element()? {
    test:function-by-annotation($functions, $annot, function($func, $meta) {
        try {
            (<ok/>, $func())[1]
        } catch * {
            <system-err>{$err:description}</system-err>
        }
    })
};

(:~
 : Calls the test function one or more times, depending on the number of
 : %args() annotations found. Each %arg annotation triggers one test run
 : using the supplied parameters.
 :)
declare %private function test:run-tests($func as function(*), $meta as element(function)) {
    if($meta/annotation[ends-with(@name,  ":pending")])then
      test:print-result($meta, (), <report>{
        element pending {
          $meta/annotation[ends-with(@name,  ":pending")]/value ! text()
        }
      }</report>)
    else
      let $argsAnnot := $meta/annotation[matches(@name, ":args?")][not(preceding-sibling::annotation[1][matches(@name, ":args?")])]
      return
          if ($argsAnnot) then
              $argsAnnot ! test:test($func, $meta, .)
          else
              test:test($func, $meta, ())
};

(:~
 : The main function for running a single test. Executes the test function
 : and compares the result against each assertXXX annotation.
 :)
declare %private function test:test($func as function(*), $meta as element(function), $firstArg as element(annotation)?) {
    let $args := test:get-run-args($firstArg)
    let $assertions := test:get-assertions($meta, $firstArg)
    let $assertError := $assertions[contains(@name, ":assertError")]
    return
        if (exists($assertions)) then
            try {
                let $result := test:call-test($func, $meta, $args)
                let $assertResult := test:check-assertions($assertions, $result)
                return
                    if ($assertError) then
                        test:print-result($meta, $result,
                            <report>
                                <failure message="Expected error {$assertError/value/string()}."
                                    type="failure-error-code-1"/>
                            </report>
                        )
                    else
                        test:print-result($meta, $result, $assertResult)
            } catch * {
                if ($assertError) then
                    if ($assertError/value and not(contains($err:code, $assertError/value/string())
                        or matches($err:description, $assertError/value/string())))then
                        test:print-result($meta, (),
                            <report>
                                <failure message="Expected error {$assertError/value/string()}, got: {$err:code} {$err:description}"
                                    type="failure-error-code-1"/>
                            </report>
                        )
                    else
                        test:print-result($meta, (), ())
                else
                    test:print-result($meta, (),
                        <report>
                            <error type="{$err:code}" message="{$err:description}"/>
                        </report>
                    )
            }
        else
            ()
};

declare function test:enable-tracing($meta as element(function)) {
    let $statsAnno := $meta//annotation[contains(@name, ":stats")]
    return
        if (exists($statsAnno)) then (
            system:clear-trace(),
            system:enable-tracing(true(), false()),
            true()
        ) else
            false()
};

(:~
 : Get all %assertXXX annotations of the function. If %args is used multiple times,
 : assertions apply to the result of running the function with the parameters given
 : in the preceding %args.
 :)
declare %private function test:get-assertions($meta as element(function), $firstArg as element(annotation)?) {
    if ($firstArg) then
        let $nextBlock :=
            $firstArg/following-sibling::annotation[matches(@name, ":args?")]
                [preceding-sibling::annotation[1][contains(@name, ":assert")]][1]
        return
            if ($nextBlock) then
                $firstArg/following-sibling::annotation[contains(@name, ":assert")]
                intersect
                $nextBlock/preceding-sibling::annotation[contains(@name, ":assert")]
            else
                $firstArg/following-sibling::annotation[contains(@name, ":assert")]
    else
        $meta/annotation[contains(@name, ":assert")]
};

(:~
 : Collect %test:arg and %test:args for the current run.
 :)
declare %private function test:get-run-args($firstArg as element(annotation)?) {
    if ($firstArg) then
        let $nextBlock :=
            $firstArg/following-sibling::annotation[matches(@name, ":args?")]
                [preceding-sibling::annotation[1][contains(@name, ":assert")]][1]
        return (
            $firstArg,
            if ($nextBlock) then
                $firstArg/following-sibling::annotation[matches(@name, ":args?")]
                intersect
                $nextBlock/preceding-sibling::annotation
            else
                $firstArg/following-sibling::annotation[matches(@name, ":args?")]
        )
    else
        ()
};

(:~
 : Map any arguments from the %args or %arg annotations into function parameters and evaluate
 : the resulting function.
 :)
declare %private function test:call-test($func as function(*), $meta as element(function), $args as element(annotation)*) {
    let $funArgs :=
        if ($args[1]/@name = "test:args") then
            test:map-arguments($args/value/string(), $meta/argument)
        else
            test:map-named-arguments($meta/argument, $args)
    return
        test:apply($func, $meta, $funArgs)
};

(:~
 : Map a sequence of %arg annotations to named function parameters.
 :)
declare %private function test:map-named-arguments($funcArgs as element(argument)*, $testArgs as element(annotation)*) {
    let $mappedArgs :=
        for $arg in $funcArgs
        let $argName := $arg/@var/string()
        let $testArg := $testArgs[value[1] = $argName]
        return
            if (empty($testArg)) then
                error($test:WRONG_ARG_COUNT, "No matching %test:arg found for parameter " || $argName)
            else
                test:map-named-argument(subsequence($testArg/value, 2), $arg)
    return
        if (count($mappedArgs) != count($funcArgs)) then
            error(
                $test:WRONG_ARG_COUNT,
                "The number of arguments specified via test:arg must match the arguments of the function to test"
            )
        else
            $mappedArgs
};

declare %private function test:map-named-argument($testArgs as element(value)*, $funcArg as element(argument)) {
    let $data :=
        try {
            test:cast($testArgs, $funcArg)
        } catch * {
            error($test:TYPE_ERROR, "Failed to cast annotation arguments to required target type " || $funcArg/@type)
        }
    return
        (: If we need to return a sequence of values, enclose them into a closure function :)
        function() { $data }
};

(:~
 : For %args: transform each annotation parameter into the type required for the function parameter.
 :)
declare %private function test:map-arguments($testArgs as xs:string*, $funcArgs as element(argument)*) {
    if (exists($testArgs)) then
        if (count($testArgs) != count($funcArgs)) then
            error(
                $test:WRONG_ARG_COUNT,
                "The number of arguments specified in test:args must match the arguments of the function to test"
            )
        else
            map-pairs(function($targ as xs:string, $farg as element(argument)) {
                let $data := test:cast($targ, $farg)
                return
                    function() { $data }
            }, $testArgs, $funcArgs)
    else
        ()
};

declare %private function test:cast($targs as xs:string*, $farg as element(argument)) {
    for $targ in $targs
    return
        switch (string($farg/@type))
            case "xs:string" return
                string($targ)
            case "xs:integer" case "xs:int" return
                xs:integer($targ)
            case "xs:decimal" return
                xs:decimal($targ)
            case "xs:float" case "xs:double" return
                xs:double($targ)
            case "xs:date" return
                xs:date($targ)
            case "xs:dateTime" return
                xs:dateTime($targ)
            case "xs:time" return
                xs:time($targ)
            case "element()" return
                util:parse($targ)/*
            case "text()" return
                text { string($targ) }
            default return
                $targ
};

declare function test:apply($func as function(*), $meta as element(function), $args as item()*) {
    let $trace := test:enable-tracing($meta)
    let $userAnno := $meta/annotation[contains(@name, ":user")]
    let $result :=
        if ($userAnno) then
            let $user := $userAnno/value[1]/string()
            let $pass := $userAnno/value[2]/string()
            return
                system:as-user($user, $pass, test:apply($func, $args))
        else
            test:apply($func, $args)
    return
        if ($trace) then
            (: Get trace output and filter out stats :)
            let $traceOutput :=
                (system:trace(), system:clear-trace(), system:enable-tracing(false()))
            return
                element { node-name($traceOutput) } {
                    $traceOutput/stats:*[not(starts-with(@source, "org.exist") or contains(@source, "xqsuite.xql"))]
                }
        else
            $result
};

(:~
 : Call the given function with parameters taken from $args.
 :)
declare %private function test:apply($func as function(*), $args as item()*) {
    switch (count($args))
        case 0 return
            $func()
        case 1 return
            $func($args[1]())
        case 2 return
            $func($args[1](), $args[2]())
        case 3 return
            $func($args[1](), $args[2](), $args[3]())
        case 4 return
            $func($args[1](), $args[2](), $args[3](), $args[4]())
        case 5 return
            $func($args[1](), $args[2](), $args[3](), $args[4](), $args[5]())
        case 6 return
            $func($args[1](), $args[2](), $args[3](), $args[4](), $args[5](), $args[6]())
        case 7 return
            $func($args[1](), $args[2](), $args[3](), $args[4](), $args[5](), $args[6](), $args[7]())
        default return
            error($test:WRONG_ARG_COUNT, "Function takes too many arguments")
};

(:~
 : Print out evaluation results for a given test.
 :)
declare %private function test:print-result($meta as element(function), $result as item()*,
    $assertResult as element(report)*) {
    let $nameAnnot := $meta/annotation[matches(@name, ":name")]
    let $name := if ($nameAnnot) then $nameAnnot/value else replace($meta/@name, "^\w+:([^:]+)$", "$1")
    return
        <testcase name="{$name}" class="{$meta/@name}">
        {
            if (exists($assertResult)) then
                ($assertResult[failure] | $assertResult)[1]/*
            else
                ()
        }
        </testcase>
};

(:~
 : Check the function's return value against each assertion.
 :)
declare %private function test:check-assertions($assertions as element(annotation)*, $result as item()*) as element(report)* {
    for $annotation in $assertions
    let $assert := replace($annotation/@name, "^\w+:(.*)$", "$1")
    return
        switch ($assert)
            case "assertEquals" return
                test:assertEquals($annotation/value/string(), $result)
            case "assertEqualsPermutation" return
                test:assertEqualsPermutation($annotation/value/string(), $result)
            case "assertEmpty" return
                test:assertEmpty($result)
            case "assertExists" return
                test:assertExists($result)
            case "assertTrue" return
                test:assertTrue($result)
            case "assertFalse" return
                test:assertFalse($result)
            case "assertXPath" return
                test:assertXPath($annotation, $result)
            case "assertError" return
                test:assertError($annotation/value/string(), $result)
            default return
                error($test:UNKNOWN_ASSERTION, $annotation/@name)
};

(:~
 : Check for equality of the function's result with the value in the annotation.
 : This function transforms the result to a string before checking for equality.
 :)
declare %private function test:assertEquals($values as item()*, $result as item()*) as element(report)? {
    if (exists($values)) then
        if (count($values) eq count($result)) then
            let $tests := map-pairs(test:equals#2, $values, $result)
            let $equal := every $test in $tests satisfies $test
            return
                if ($equal) then
                    ()
                else
                   <report>
                        <failure message="assertEquals failed."
                            type="failure-error-code-1">
                        { $values }
                        </failure>
                        <output>{ $result }</output>
                    </report>
        else
            <report>
                <failure message="assertEquals failed: wrong number of items returned by function. Expected: {count($values)}. Got: {count($result)}"
                    type="failure-error-code-1">
                { $values }
                </failure>
                <output>{ $result }</output>
            </report>
    else
        ()
};

(:~
 : Check for equality of the function's result with the value in the annotation.
 : This function transforms the result to a string before checking for equality.
 :)
declare %private function test:assertEqualsPermutation($values as item()*, $result as item()*) as element(report)? {
    if (exists($values)) then
        if (count($values) eq count($result)) then
            let $tests :=
                for $item in $result
                return
                    some $value in $values satisfies test:equals($item, $value)
            let $equal := every $test in $tests satisfies $test
            return
                if ($equal) then
                    ()
                else
                   <report>
                        <failure message="assertEquals failed."
                            type="failure-error-code-1">
                        { $values }
                        </failure>
                        <output>{ $result }</output>
                    </report>
        else
            <report>
                <failure message="assertEquals failed: wrong number of items returned by function. Expected: {count($values)}. Got: {count($result)}"
                    type="failure-error-code-1">
                { $values }
                </failure>
                <output>{ $result }</output>
            </report>
    else
        ()
};

declare %private function test:equals($value as item(), $result as item()) as xs:boolean {
    let $normResult :=
        typeswitch ($result)
            case node() return
                test:normalize($result)
            default return
                $result
    let $normValue := test:cast-to-type($value, $result)
    return
        typeswitch ($normResult)
            case node() return
                deep-equal($normValue, $normResult)
            default return
                $normResult eq $normValue
};

declare %private function test:normalize($nodes as node()*) {
    $nodes ! test:normalize-node(.)
};

declare %private function test:normalize-node($node as node()) {
    typeswitch ($node)
        case document-node() return
            test:normalize-node($node/*)
        case element() return
            element { node-name($node) } {
                $node/@*, for $child in $node/node() return test:normalize-node($child)
            }
        case text() return
            let $norm := normalize-space($node)
            return
                if (string-length($norm) eq 0) then () else $node
        default return
            $node
};

(:~
 : Check if the function's result is empty.
 :)
declare %private function test:assertEmpty($result as item()*) as element(report)? {
    if (empty($result)) then
        ()
    else
        <report>
            <failure message="assertEmpty failed."
                type="failure-error-code-1"/>,
            <output>{ $result }</output>
        </report>
};

(:~
 : Check if the function's result is not empty.
 :)
declare %private function test:assertExists($result as item()*) as element(report)? {
    if (exists($result)) then
        ()
    else
        <report>
            <failure message="assertExists failed."
                type="failure-error-code-1"/>,
            <output>{ $result }</output>
        </report>
};

(:~
 : Check if the function's result is true.
 :)
declare %private function test:assertTrue($result as item()*) as element(report)? {
    if ($result) then
        ()
    else
        <report>
            <failure message="assertExists failed."
                type="failure-error-code-1"/>,
            <output>{ $result }</output>
        </report>
};

(:~
 : Check if the function caused an error.
 :)
declare %private function test:assertError($value as xs:string, $result as item()*) as element(report)? {
    if ($result) then
        ()
    else
        <report>
            <failure message="assertError failed. Expected error {$value}"
                type="failure-error-code-1"/>,
            <output>{ $result }</output>
        </report>
};

(:~
 : Check if the function's result is false.
 :)
declare %private function test:assertFalse($result as item()*) as element(report)? {
    if (not($result)) then
        ()
    else
        <report>
            <failure message="assertExists failed."
                type="failure-error-code-1"/>,
            <output>{ $result }</output>
        </report>
};

(:~
 : Evaluate an arbitrary XPath expression against result. The test passes if
 : the XPath returns either true or a non-empty sequence.
 :)
declare %private function test:assertXPath($annotation as element(annotation), $output as item()*) as element(report)? {
    let $expr := $annotation/value[1]/string()
    let $result :=
        if (count($annotation/value) = 2 and boolean($annotation/value[2])) then
            util:expand($output)
        else
            $output
    let $prolog :=
        if ($result instance of element()*) then
            let $namespaces := fold-left($result/descendant-or-self::*, map:new(),
                function ($namespaces as map(*), $xml as element()) {
                    map:new(($namespaces,
                	    for $prefix in in-scope-prefixes($xml)
                	    where $prefix != "" and $prefix != "xml"
                	    return
                	        map:entry($prefix, namespace-uri-for-prefix($prefix, $xml))
                    ))
                }
            )
            return
                string-join(
                    for $prefix in map:keys($namespaces)
                    return
                        "declare namespace " || $prefix || "='" || $namespaces($prefix) || "';",
                    " "
                )
        else
            ()
    let $xr :=
        test:checkXPathResult(
            if (matches($expr, "^\s*/")) then
                util:eval($prolog || "$result" || $expr)
            else
                util:eval($prolog || $expr)
        )
    return
        if ($xr) then
            ()
        else
            <report>
                <failure message="assertXPath failed."
                    type="failure-error-code-1">{ $expr }</failure>,
                <output>{ $result }</output>
            </report>
};

declare %private function test:checkXPathResult($result as item()*) {
    if ($result instance of xs:boolean) then
        $result
    else
        exists($result)
};

declare %private function test:cast-to-type($value as item(), $result as item()) {
    typeswitch ($result)
        case node() return
            util:parse("<r>" || $value || "</r>")/r/node()
        case xs:integer return
            xs:integer($value)
        case xs:int return
            xs:int($value)
        case xs:long return
            xs:long($value)
        case xs:decimal return
            xs:decimal($value)
        case xs:double return
            xs:double($value)
        case xs:float return
            xs:float($value)
        case xs:date return
            xs:date($value)
        case xs:dateTime return
            xs:dateTime($value)
        case xs:time return
            xs:time($value)
        case xs:boolean return
            xs:boolean($value)
        case xs:anyURI return
            xs:anyURI($value)
        default return
            string($value)
};

(: Helper functions to be used by test modules :)

declare function test:mkcol($root as xs:string, $path as xs:string) as empty() {
    test:mkcol-recursive($root, tokenize($path, "/"))
};

declare %private function test:mkcol-recursive($collection, $components) as empty() {
    if (exists($components)) then
        let $newColl := concat($collection, "/", $components[1])
        return (
            xmldb:create-collection($collection, $components[1])[2],
            test:mkcol-recursive($newColl, subsequence($components, 2))
        )
    else
        ()
};

declare function test:to-html($output as element(testsuites)) {
    <div class="testresult">
    {
        $output/testsuite !
            <section>
                <h2>{@package/string()}</h2>
                <table>
                {
                    for $case in testcase
                    return
                        test:print-testcase($case)
                }
                </table>
            </section>
    }
    </div>
};

declare %private function test:print-testcase($case as element(testcase)) {
    <tr class="{if ($case/failure or $case/error) then 'fail' else 'pass'}">
        <td>{$case/@name/string()}</td>
        <td>
        {
            if ($case/failure) then
                ($case/failure/@message/string(), " Expected: ", $case/failure/text())
            else if ($case/error) then
                ($case/error/@type/string(), " ", $case/error/@message/string())
            else
                "OK"
        }
        </td>
    </tr>
};


Humord: Oppdaterer diskusjon om toppbegreper

import module namespace emneregister="http://ub.uio.no/emneregister"
  at "../emneregister.xq";

declare namespace marcxml = "http://www.loc.gov/MARC21/slim";
declare namespace rdf     = "http://www.w3.org/1999/02/22-rdf-syntax-ns#";
declare namespace rdfs    = "http://www.w3.org/2000/01/rdf-schema#";
declare namespace skos    = "http://www.w3.org/2004/02/skos/core#";
declare namespace dcterms = "http://purl.org/dc/terms/";

declare variable $scheme := 'http://data.ub.uio.no/usvd/';
declare variable $uri_base := 'http://data.ub.uio.no/usvd/';

(: To test a specific post: :)
(: emneregister:post(doc('USVDregister.xml')/usvd/post[descendant::term-id/text()="USVD21236"]) :)

emneregister:toRdf( doc( 'USVDregister.xml' )/usvd/post, $scheme, $uri_base, 'ddc' )

import module namespace emneregister="http://ub.uio.no/emneregister"
  at "../emneregister.xq";

declare namespace marcxml = "http://www.loc.gov/MARC21/slim";
declare namespace rdf     = "http://www.w3.org/1999/02/22-rdf-syntax-ns#";
declare namespace rdfs    = "http://www.w3.org/2000/01/rdf-schema#";
declare namespace skos    = "http://www.w3.org/2004/02/skos/core#";
declare namespace dcterms = "http://purl.org/dc/terms/";

declare variable $scheme := 'http://data.ub.uio.no/usvd/';
declare variable $uri_base := $scheme;

(: To test a specific post: :)
(: emneregister:post(doc('USVDregister.xml')/usvd/post[descendant::term-id/text()="USVD21236"]) :)

emneregister:toRdf( doc( 'USVDregister.xml' )/usvd/post, $scheme, $uri_base, 'ddc' )


.xq filesq are text files

.xq filesq are text files

svn path=/trunk/eXist-1.0/; revision=1939

xquery version "1.0";

declare namespace request="http://exist-db.org/xquery/request";
declare namespace util="http://exist-db.org/xquery/util";

(: Namespace for the local functions in this script :)
declare namespace f="http://exist-db.org/xquery/local-functions";

(:
    Display hits for the current page. The number of hits to print per page
    is read from parameter "howmany". Parameter "start" identifies the
    current offset in the result set.
:)
declare function f:display($hits as item()*, $count as xs:int)
as element()+
{
    if (empty($hits)) then

Nothing found! Back to query form.

    else
        let $howmany := request:request-parameter("howmany", "10") cast as xs:int,
            $start := request:request-parameter("start", "1") cast as xs:int,
            $end := if ($start + $howmany le $count) then $start + $howmany - 1 else $count
        return (

                        <New Query>

                { f:navbar($start, $end, $howmany, $count) }
                {
                    for $p in $start to $end
                    let $current := item-at($hits, $p),
                        $style := if($p mod 2 eq 0) then "high" else "low"
                    return

                            {$p}

                                {
                                    if ($current instance of element()) then
                                        <xml-source>{$current}</xml-source>
                                    (: TODO : revisit :)
                                    else if ($current instance of attribute()) then
                                    	concat("attribute ", local-name($current), " { ", data($current), " }")
									else if ($current instance of processing-instruction()) then
                                    	concat("processing-instruction { ", name($current), " } { ", data($current), " }")
									else if ($current instance of comment()) then
                                    	concat("comment { ", data($current), " }")
                                    else
                                        string($current)
                                }

                }
                { f:navbar($start, $end, $howmany, $count) }

                        <New Query>

        )
};

(: Display the navigation bar :)
declare function f:navbar($start as xs:int, $end as xs:int,
$hitsPerPage as xs:int, $count as xs:int) as element()
{
    let $uri := request:request-uri()
    return

                {
                    (: Link to previous page :)
                    if ($start gt 1) then
                        <<
                    else ()
                }

                {
                    (: Create page shortcuts :)
                    let $sections := $count idiv $hitsPerPage - 1,
                        $currentSection := $start idiv $hitsPerPage,
                        $lastSection :=
                            if ($sections lt 0) then 0 else
                                (: show 10 max unless current page > 10 :)
                                if ($sections gt 9) then
                                    if ($currentSection gt 8) then $currentSection + 1
                                    else 9
                                else $sections
                    for $i in 0 to $lastSection
                    let $s := xs:int($i * $hitsPerPage + 1)
                    return
                        if($i ne $currentSection) then

                                [{$i + 1}]

                        else
                            (: current page doesn't get a link :)
                            [{$i + 1}]
                }

                {
                    (: Link to next page :)
                    if ($end lt $count) then

                            >>

                    else ()
                }

};

(: Auxiliary function called in add-to-history()
   to avoid having twice the same query in history
:)
declare function f:string-list-union(
   $list as xs:string*,
   $s as xs:string ) as xs:string*
{
  let $contains := some $ss in $list satisfies $ss eq $s

  return
    if ( $contains ) then
      $list
    else
      ( $list, $s )
};

(:  Add the last query to the query-history. The history is
    stored in the session as an XQuery sequence.
:)
declare function f:add-to-history($query as xs:string) as empty()
{
    let $history := request:get-session-attribute("history")
    return
        request:set-session-attribute( "history",
                                       f:string-list-union($history, $query) )
};

declare function f:handleException() as element()+
{
	,

Defined server limits exceeded!
,
	(
		if($util:exception eq
			"org.exist.xquery.TerminatedException$TimeoutException") then

The execution time of your query exceeded the predefined limits.
			It has been forced to terminate.

		else

The query exceeded the predefined size limits for
			temporary document fragments and has been forced to
			terminate.

	),

Limits can be configured! Please have a look at the
	"watchdog" section in the configuration file (conf.xml).

};

declare function f:eval($query as xs:string) as element()+
{
	let $startTime := util:system-time(),
		$collection := request:request-parameter("collection", ())
	return
		util:catch("org.exist.xquery.TerminatedException",
            util:catch("org.exist.xquery.XPathException",
                let	$result := util:eval($query, $collection),
                    $count := count($result),
                    $queryTime := util:system-time() - $startTime
                return (

Found {$count} hits in
                    {seconds-from-duration($queryTime)} seconds.
                    {if($count gt 100) then "Max. 100 will be shown." else ()}

,
                    request:set-session-attribute(
                        "results",
                        subsequence($result, 1, 100)
                    ),
                    f:add-to-history($query),
                    f:display($result, $count)
                ),

Error found: {$util:exception-message}.

            ),
			f:handleException()
		)
};

(:  The main function. If a query has been passed in parameter
    "query", execute the query and store the results into the
    session. If "query" is empty, try to retrieve the previous
    result set from the session.
:)
declare function f:main() as element()+
{
    let $query := request:request-parameter("query", ()),
        $previous := request:get-session-attribute("results")
    return
        if ($query) then
           f:eval($query)
        else if ($previous) then
            f:display($previous, count($previous))
        else

Please specify a query! Back to query
            form.

};

<document xmlns:xi="http://www.w3.org/2001/XInclude">

        <logo src="logo.jpg"/>
        <title>Open Source XML Database</title>
	    <author email="wolfgang@exist-db.org">Wolfgang M. Meier</author>

xquery version "1.0";

declare namespace request="http://exist-db.org/xquery/request";
declare namespace util="http://exist-db.org/xquery/util";

(: Namespace for the local functions in this script :)
declare namespace f="http://exist-db.org/xquery/local-functions";

(:
    Display hits for the current page. The number of hits to print per page
    is read from parameter "howmany". Parameter "start" identifies the
    current offset in the result set.
:)
declare function f:display($hits as item()*, $count as xs:int)
as element()+
{
    if (empty($hits)) then

Nothing found! Back to query form.

    else
        let $howmany := request:request-parameter("howmany", "10") cast as xs:int,
            $start := request:request-parameter("start", "1") cast as xs:int,
            $end := if ($start + $howmany le $count) then $start + $howmany - 1 else $count
        return (

                        <New Query>

                { f:navbar($start, $end, $howmany, $count) }
                {
                    for $p in $start to $end
                    let $current := item-at($hits, $p),
                        $style := if($p mod 2 eq 0) then "high" else "low"
                    return

                            {$p}

                                {
                                    if ($current instance of element()) then
                                        <xml-source>{$current}</xml-source>
                                    else
                                        string($current)
                                }

                }
                { f:navbar($start, $end, $howmany, $count) }

                        <New Query>

        )
};

(: Display the navigation bar :)
declare function f:navbar($start as xs:int, $end as xs:int,
$hitsPerPage as xs:int, $count as xs:int) as element()
{
    let $uri := request:request-uri()
    return

                {
                    (: Link to previous page :)
                    if ($start gt 1) then
                        <<
                    else ()
                }

                {
                    (: Create page shortcuts :)
                    let $sections := $count idiv $hitsPerPage - 1,
                        $currentSection := $start idiv $hitsPerPage,
                        $lastSection :=
                            if ($sections lt 0) then 0 else
                                (: show 10 max unless current page > 10 :)
                                if ($sections gt 9) then
                                    if ($currentSection gt 8) then $currentSection + 1
                                    else 9
                                else $sections
                    for $i in 0 to $lastSection
                    let $s := xs:int($i * $hitsPerPage + 1)
                    return
                        if($i ne $currentSection) then

                                [{$i + 1}]

                        else
                            (: current page doesn't get a link :)
                            [{$i + 1}]
                }

                {
                    (: Link to next page :)
                    if ($end lt $count) then

                            >>

                    else ()
                }

};

(: Auxiliary function called in add-to-history()
   to avoid having twice the same query in history
:)
declare function f:string-list-union(
   $list as xs:string*,
   $s as xs:string ) as xs:string*
{
  let $contains := some $ss in $list satisfies $ss eq $s

  return
    if ( $contains ) then
      $list
    else
      ( $list, $s )
};

(:  Add the last query to the query-history. The history is
    stored in the session as an XQuery sequence.
:)
declare function f:add-to-history($query as xs:string) as empty()
{
    let $history := request:get-session-attribute("history")
    return
        request:set-session-attribute( "history",
                                       f:string-list-union($history, $query) )
};

declare function f:handleException() as element()+
{
	,

Defined server limits exceeded!
,
	(
		if($util:exception eq
			"org.exist.xquery.TerminatedException$TimeoutException") then

The execution time of your query exceeded the predefined limits.
			It has been forced to terminate.

		else

The query exceeded the predefined size limits for
			temporary document fragments and has been forced to
			terminate.

	),

Limits can be configured! Please have a look at the
	"watchdog" section in the configuration file (conf.xml).

};

declare function f:eval($query as xs:string) as element()+
{
	let $startTime := current-time(),
		$collection := request:request-parameter("collection", ())
	return
		util:catch("org.exist.xquery.TerminatedException",
            util:catch("org.exist.xquery.XPathException",
                let	$result := util:eval($query, $collection),
                    $count := count($result),
                    $queryTime := current-time() - $startTime
                return (

Found {$count} hits in
                    {seconds-from-duration($queryTime)} seconds.
                    {if($count gt 100) then "Max. 100 will be shown." else ()}

,
                    request:set-session-attribute(
                        "results",
                        subsequence($result, 1, 100)
                    ),
                    f:add-to-history($query),
                    f:display($result, $count)
                ),

Error found: {$util:exception-message}.

            ),
			f:handleException()
		)
};

(:  The main function. If a query has been passed in parameter
    "query", execute the query and store the results into the
    session. If "query" is empty, try to retrieve the previous
    result set from the session.
:)
declare function f:main() as element()+
{
    let $query := request:request-parameter("query", ()),
        $previous := request:get-session-attribute("results")
    return
        if ($query) then
           f:eval($query)
        else if ($previous) then
            f:display($previous, count($previous))
        else

Please specify a query! Back to query
            form.

};

<document xmlns:xi="http://www.w3.org/2001/XInclude">

        <logo src="logo.jpg"/>
        <title>Open Source XML Database</title>
	    <author email="wolfgang@exist-db.org">Wolfgang M. Meier</author>