Corrected xqdoc error.

Corrected xqdoc error.

xquery version "1.0";

(:
 : Copyright 2006-2012 The FLWOR Foundation.
 :
 : Licensed under the Apache License, Version 2.0 (the "License");
 : you may not use this file except in compliance with the License.
 : You may obtain a copy of the License at
 :
 : http://www.apache.org/licenses/LICENSE-2.0
 :
 : Unless required by applicable law or agreed to in writing, software
 : distributed under the License is distributed on an "AS IS" BASIS,
 : WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 : See the License for the specific language governing permissions and
 : limitations under the License.
:)

(:~
 : This module provides the functions defined by the JSONiq specification,
 : chapter 8 (Function Library). JSONiq extends
 : the XQuery specification to also deal with JSON data natively. See
 :
 :     http://www.jsoniq.org/
 :
 : for details.
 :
 : This module depends on having the JSONiq feature enabled in Zorba,
 : i.e., Zorba must be compiled with ZORBA_WITH_JSON.
 :
 : @author Ghislain Fourny
 :)
module namespace libjn = "http://www.jsoniq.org/function-library";

import module namespace jn = "http://www.jsoniq.org/functions";

declare namespace ver = "http://www.zorba-xquery.com/options/versioning";
declare option ver:module-version "1.0";

(:~
 : This function dynamically builds an object, like jn:object, except that
 : it does not throw an error upon pair collision. Instead, it aggregates them
 : into an array.
 :
 : @param $o A sequence of objects.
 : @return The accumulated object.
 :)
declare function libjn:accumulate($o as object()*) as object()
{
  {[ $o ]}
};

(:~
 : This function returns all Objects contained within a JSON item, regardless of
 : depth.
 :
 : @param $i A JSON item.
 : @return Its descendant objects.
 :)
declare function libjn:descendant-objects($i as json-item()) as object()*
{
  if ($i instance of object())
  then
    (
      $i,
      for $v in libjn:values($i)
      where $v instance of json-item()
      return libjn:descendant-objects($v)
    )
  else if ($i instance of array())
  then
    (
      for $v in libjn:members($i)
      where $v instance of json-item()
      return libjn:descendant-objects($v)
    )
  else
    ()
};

(:~
 : This function returns all pairs contained within an object, recursively.
 :
 : @param $o An object.
 : @return All direct and indirect descendant pairs.
 :)
declare function libjn:descendant-pairs($o as object()) as object()*
{
  for $k in jn:keys($o)
  return (
    { $k : $o($k) },
    if ($o($k) instance of object())
    then
      libjn:descendant-pairs($o($k))
    else ()
  )
};

(:~
 : Recursively "flatten" a JSON Array, by replacing any arrays with their
 : members. Equivalent to
 :
 :   define function jn:flatten($arg as array()) {
 :     for $value in jn:values($arg)
 :     return
 :       if ($value instance of array())
 :       then jn:flatten($value)
 :       else $value
 :   };
 :
 : @param $a A JSON Array.
 : @return The flattened version of $a.
 :)
declare function libjn:flatten($a as array()) as item()*
{
  jn:flatten($a)
};

(:~ This function returns the intersection of two objects, and aggregates
 : values corresponding to the same name into an array.
 :
 : @param $o A sequence of objects.
 : @return Their insersection.
 :)
declare function libjn:intersect($o as object()*) as object()
{
  {|
    let $common-keys := jn:keys($o[1])[ every $object in $o[position() > 1]
                                           satisfies jn:keys($object) = . ]
    for $key in $common-keys
    let $values := $o($key)
    return
      if (count($values) eq 1)
      then { $key : $values }
      else { $key : [ $values ] }
  |}
};

(:~
 : Returns the members of an Array.
 :
 : @param $a A JSON Array.
 : @return The members of the specified array.
 :)
declare function libjn:members($o as array()) as item()*
{
  jn:members($o)
};

(:~
 : Creates an object from the specified pairs of another given object.
 : Specifically, for each name in $names, if the object $o has a pair with
 : that name, then a copy of that pair is included in the new object.
 :
 : @param $o A JSON Object.
 : @param $names The names of the pairs to copy out of $o and insert into the new object
 : @return The new object.
 :)
declare function libjn:project($o as object(), $names as xs:string*) as object()
{
  jn:project($o, $names)
};

(:~
 : This functions returns all values in an Object.
 : @param $i An object.
 : @return Its values.
 :)
declare function libjn:values($i as object()) as item()*
{
  for $k in jn:keys($i)
  return $i($k)
};

xquery version "1.0";

(:
 : Copyright 2006-2012 The FLWOR Foundation.
 :
 : Licensed under the Apache License, Version 2.0 (the "License");
 : you may not use this file except in compliance with the License.
 : You may obtain a copy of the License at
 :
 : http://www.apache.org/licenses/LICENSE-2.0
 :
 : Unless required by applicable law or agreed to in writing, software
 : distributed under the License is distributed on an "AS IS" BASIS,
 : WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 : See the License for the specific language governing permissions and
 : limitations under the License.
:)

(:~
 : This module provides the functions defined by the JSONiq specification,
 : chapter 8 (Function Library). JSONiq extends
 : the XQuery specification to also deal with JSON data natively. See
 :
 :     http://www.jsoniq.org/
 :
 : for details.
 :
 : This module depends on having the JSONiq feature enabled in Zorba,
 : i.e., Zorba must be compiled with ZORBA_WITH_JSON.
 :
 : @author Ghislain Fourny
 :)
module namespace libjn = "http://www.jsoniq.org/function-library";

declare namespace ver = "http://www.zorba-xquery.com/options/versioning";
declare option ver:module-version "1.0";

(:~
 : This function dynamically builds an object, like jn:object, except that
 : it does not throw an error upon pair collision. Instead, it aggregates them
 : into an array.
 :
 : @param $o A sequence of objects.
 : @return The accumulated object.
 :)
declare function libjn:accumulate($o as object()*) as object()
{
  {[ $o ]}
};

(:~
 : This function returns all Objects contained within a JSON item, regardless of
 : depth.
 :
 : @param $i A JSON item.
 : @return Its descendant objects.
 :)
declare function libjn:descendant-objects($i as json-item()) as object()*
{
  if ($i instance of object())
  then
    (
      $i,
      for $v in libjn:values($i)
      where $v instance of json-item()
      return libjn:descendant-objects($v)
    )
  else if ($i instance of array())
  then
    (
      for $v in libjn:members($i)
      where $v instance of json-item()
      return libjn:descendant-objects($v)
    )
  else
    ()
};

(:~
 : This function returns all pairs contained within an object, recursively.
 :
 : @param $o An object.
 : @return All direct and indirect descendant pairs.
 :)
declare function libjn:descendant-pairs($o as object()) as object()*
{
  for $k in jn:keys($o)
  return (
    { $k : $o($k) },
    if ($o($k) instance of object())
    then
      libjn:descendant-pairs($o($k))
    else ()
  )
};

(:~
 : Recursively "flatten" a JSON Array, by replacing any arrays with their
 : members. Equivalent to
 :
 :   define function jn:flatten($arg as array()) {
 :     for $value in jn:values($arg)
 :     return
 :       if ($value instance of array())
 :       then jn:flatten($value)
 :       else $value
 :   };
 :
 : @param $a A JSON Array.
 : @return The flattened version of $a.
 :)
declare function libjn:flatten($a as array()) as item()*
{
  jn:flatten($a)
};

(:~ This function returns the intersection of two objects, and aggregates
 : values corresponding to the same name into an array.
 :
 : @param $o A sequence of objects.
 : @return Their insersection.
 :)
declare function libjn:intersect($o as object()*) as object()
{
  {|
    let $common-keys := jn:keys($o[1])[ every $object in $o[position() > 1]
                                           satisfies jn:keys($object) = . ]
    for $key in $common-keys
    let $values := $o($key)
    return
      if (count($values) eq 1)
      then { $key : $values }
      else { $key : [ $values ] }
  |}
};

(:~
 : Returns the members of an Array.
 :
 : @param $a A JSON Array.
 : @return The members of the specified array.
 :)
declare function libjn:members($o as array()) as item()*
{
  jn:members($o)
};

(:~
 : Creates an object from the specified pairs of another given object.
 : Specifically, for each name in $names, if the object $o has a pair with
 : that name, then a copy of that pair is included in the new object.
 :
 : @param $o A JSON Object.
 : @param $names The names of the pairs to copy out of $o and insert into the new object
 : @return The new object.
 :)
declare function libjn:project($o as object(), $names as xs:string*) as object()
{
  jn:project($o, $names)
};

(:~
 : This functions returns all values in an Object.
 : @param $i An object.
 : @return Its values.
 :)
declare function libjn:values($i as object()) as item()*
{
  for $k in jn:keys($i)
  return $i($k)
};


update webap ui

update webap ui

(:~
: This is a module conttaining configuration options for the openinfoman webap
: @version 1.0
: @see https://github.com/openhie/openinfoman @see http://ihe.net
:
:)

module namespace csd_webui = "https://github.com/openhie/openinfoman/csd_webui";
import module namespace csd_webconf =  "https://github.com/openhie/openinfoman/csd_webconf";
import module namespace request = "http://exquery.org/ns/request";

declare function csd_webui:generateURL() {
  csd_webui:generateURL(())
};

declare function csd_webui:generateURL($end) {
  let $cend :=
    functx:string-join(
      for $e in $end
      return replace(replace(string($e),'^/+',''),'/+$','')
      ,'/')

  let $cbegin :=
    if (functx:all-whitespace($csd_webconf:baseurl))
    then concat(request:scheme(),"://",request:hostname(),":",request:port())
    else replace($csd_webconf:baseurl, '/+$', '')

  return concat($cbegin,'/',$cend)

};

declare function csd_webui:nocache($response)
{(
  <rest:response>
    <http:response >
      <http:header name="Cache-Control" value="must-revalidate,no-cache,no-store"/>
    </http:response>
  </rest:response>
  ,
  $response
)};

declare function csd_webui:redirect() as element(restxq:redirect) {
  csd_webui:redirect(())
};

declare function csd_webui:redirect($end ) as element(restxq:redirect)
{
  <restxq:redirect>{ csd_webui:generateURL($end }</restxq:redirect>
};

declare function csd_webui:redirect_out() as element(restxq:redirect) {
  csd_webui:redirect_out(())
};

declare function csd_webui:redirect_out($end ) as element(restxq:redirect)
{
  db:output(<restxq:redirect>{ csd_webui:generateURL($end }</restxq:redirect>)
};

declare function csd_webui:wrapper($content) {
  csd_webui:wrapper($content,())
};

declare function csd_webui:wrapper($content,$headers) {

    <link href="{$csd_webui:generateURL('static/bootstrap/css/bootstrap.css')}" rel="stylesheet"/>
    <link href="{$csd_webui:generateURL('static/bootstrap/css/bootstrap-theme.css')}" rel="stylesheet"/>
    <link rel="shortcut icon" href="{$csd_webui:generateURL(,'static/favicon.ico')}"/>

(:~
: This is a module conttaining configuration options for the openinfoman webap
: @version 1.0
: @see https://github.com/openhie/openinfoman @see http://ihe.net
:
:)

module namespace csd_webui = "https://github.com/openhie/openinfoman/csd_webui";
import module namespace csd_webconf =  "https://github.com/openhie/openinfoman/csd_webconf";
import module namespace request = "http://exquery.org/ns/request";

declare function csd_webui:generateURL() {
  csd_webui:generateURL(())
};

declare function csd_webui:generateURL($end as item*) {
  let $cend :=
    functx:string-join(
      for $e in $end
      return replace(replace(string($e),'^/+',''),'/+$','')
      ,'/')

  let $cbegin :=
    if (functx:all-whitespace($csd_webconf:baseurl))
    then concat(request:scheme(),"://",request:hostname(),":",request:port())
    else replace($csd_webconf:baseurl, '/+$', '')

  return concat($cbegin,'/',$cend)

};

declare function csd_webui:nocache($response)
{(
  <rest:response>
    <http:response >
      <http:header name="Cache-Control" value="must-revalidate,no-cache,no-store"/>
    </http:response>
  </rest:response>
  ,
  $response
)};

declare function csd_webui:redirect() as element(restxq:redirect) {
  csd_webui:redirect(())
};

declare function csd_webui:redirect($end*) as element(restxq:redirect)
{
  <restxq:redirect>{ csd_webui:generateURL($end }</restxq:redirect>
};

declare function csd_webui:redirect_out() as element(restxq:redirect) {
  csd_webui:redirect_out(())
};

declare function csd_webui:redirect_out($end*) as element(restxq:redirect)
{
  db:output(<restxq:redirect>{ csd_webui:generateURL($end }</restxq:redirect>)
};

declare function csd_webui:wrapper($content) {
  csd_webui:wrapper($content,())
};

declare function csd_webui:wrapper($content,$headers) {

    <link href="{$csd_webui:generateURL('static/bootstrap/css/bootstrap.css')}" rel="stylesheet"/>
    <link href="{$csd_webui:generateURL('static/bootstrap/css/bootstrap-theme.css')}" rel="stylesheet"/>
    <link rel="shortcut icon" href="{$csd_webui:generateURL(,'static/favicon.ico')}"/>


Fix bug in xf:extract

Fix bug in xf:extract

xquery version "3.0";

(:~
 : Origami templating.
 :
 : Requires Basex 8.0 20141219 or later.
 :
 : @version 0.4
 : @author Marc van Grootel
 : @see https://github.com/xokomola/origami
 :)

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

(:~
 : Load an HTML resource.
 :)
declare function xf:html-resource($url-or-path) {
    if (starts-with($url-or-path,'http:/')) then
        xf:fetch-html($url-or-path)
    else
        xf:parse-html($url-or-path)
};

(:~
 : Load an XML resource.
 :)
declare function xf:xml-resource($url-or-path) {
    doc($url-or-path)
};

(:~
 : Fetch and parse HTML given a URL.
 :)
declare function xf:fetch-html($url) {
    html:parse(fetch:binary($url))
};

(:~
 : Parse HTML from a filesystem path.
 :)
declare function xf:parse-html($path) {
    html:parse(file:read-binary($path))
};

(:~
 : Returns a Transformer function.
 :)
declare function xf:transform($templates as array(*)*)
    as function(node()*) as node()* {
    let $templates :=
        for $template in $templates
        return xf:match($template)
    return
        function($nodes as node()*) as node()* {
            xf:apply-nodes($nodes, (), $templates)
        }
};

(:~
 : Transform input, using the specified templates.
 :)
declare function xf:transform($nodes as node()*, $templates as array(*)*)
    as node()* {
    xf:transform($templates)($nodes)
};

(:~
 : Identity transformer.
 :)
declare function xf:transform() { xf:transform(()) };

(:~
 : Returns an extractor function that only returns selected nodes
 : only outermost, in document order and duplicates eliminated.
 :)
declare function xf:extract($selectors as array(*)*)
    as function(node()*) as node()* {
    xf:extract-outer($selectors)
};

(:~
 : Extracts nodes from input, using the specified selectors.
 :)
declare function xf:extract($nodes as node()*, $selectors as array(*)*)
    as node()* {
    xf:extract($selectors)($nodes)
};

(:~
 : Returns an extractor function that returns selected nodes,
 : only innermost, in document order and duplicates eliminitated.
 :
 : TODO: when using ['*',()] this should delete the element
 :
 : TODO: this version still suffers from the problem with transforms
 :       being done before the inner/outermost which means that
 :       they still frustrate the distinct/duplicate nodes stuff
 :)
declare function xf:extract-inner($selectors as array(*)*)
    as function(node()*) as node()* {
    let $selectors :=
        for $selector in $selectors
        return
            xf:at($selector)
    return
        function($nodes as node()*) as node()* {
            innermost(
                for $selector in $selectors
                return $selector($nodes)
            )
        }
};

declare function xf:extract-inner($nodes as node()*, $selectors as array(*)*)
    as node()* {
    xf:extract-inner($selectors)($nodes)
};

(:~
 : Returns an extractor function that returns selected nodes,
 : only outermost, in document order and duplicates eliminated.
 :)
declare function xf:extract-outer($selectors as array(*)*)
    as function(node()*) as node()* {
    let $selectors :=
        for $selector in $selectors
        return xf:at($selector)
    return
        function($nodes as node()*) as node()* {
            outermost(
                for $selector in $selectors
                return $selector($nodes)
            )
        }
};

declare function xf:extract-outer($nodes as node()*, $selectors as array(*)*)
    as node()* {
    xf:extract-outer($selectors)($nodes)
};

(:~
 : Defines a match template.
 :
 : A template takes a selector string or function and
 : a node transformation function or the items to return as
 : the template body.
 : Providing invalid matcher returns empty sequence.
 :)
declare function xf:match($template as array(*))
    as map(*)? {
    let $selector := xf:selector([array:head($template)])
    (: HACK: to work around an array:fold-left bug in 20141219 :)
    let $body := xf:do(array:filter($template,function($i) { not($i instance of xs:string) }))
    where array:size($template) gt 0
    return
        map {
            'select': $selector,
            'fn': $body
        }
};

declare function xf:at($steps as array(*))
    as function(node()*) as node()* {
    xf:selector($steps, xf:select-all#1)
};
(:~
 : Execute a chain of node selectors.
 :)
declare function xf:at($nodes as node()*, $selector as item()*) {
    xf:at($selector)($nodes)
};

(:~
 : Define a transformation that starts with selecting nodes with an
 : XPath expression.
 :)
declare %private function xf:selector($steps as array(*), $selector-fn as function(*))
    as function(node()*) as node()* {
    (: compile the steps :)
    let $steps :=
        array:fold-left(
            $steps,
            (),
            function($result, $step) {
                if ($step instance of xs:string) then
                    ($result, $selector-fn($step))
                else if ($step instance of function(*)) then
                    ($result, $step)
                else if ($step instance of node()*) then
                    ($result, function($node as node()*) as node()* { $step })
                else if ($step instance of empty-sequence()) then
                    function($node as node()*) as node()* { () }
                else
                    ($result, text { $step })
            }
        )
    return
        function($nodes as node()*) as node()* {
            for $selected in head($steps)($nodes)
            return
                fold-left(
                    tail($steps),
                    $selected,
                    function($result, $step) {
                        $step($result)
                    }
                )
        }
};

declare %private function xf:selector($steps as array(*))
    as function(node()*) as node()* {
    xf:selector($steps, xf:select-all#1)
};
(:~
 : Only nodes for which the chain of expressions evaluates to `true()`
 : are passed through.
 :
 : TODO: need to do proper xpath expression evaluation (not used descendent)
 :)
declare function xf:if($conditions as item()*)
    as function(node()*) as node()* {
    let $conditions := xf:comp-expression($conditions)
    return
        function($nodes as node()*) as node()* {
            fold-left(
                $conditions,
                $nodes,
                function($result, $step) {
                    if ($step($result)) then
                       $result
                    else
                        ()
                }
            )
        }
};

(:~
 : Filter nodes based on evaluating a chain of expressions, letting only
 : those nodes through for which it returns `true()`.
 :)
declare function xf:if($nodes as node()*, $conditions as item()*)
    as node()* {
    xf:if($conditions)($nodes)
};

(:~
 : Compose a chain of node transformers.
 :)
declare function xf:do($fns as array(*))
    as function(node()*) as node()* {
    function($nodes as node()*) as node()* {
        array:fold-left(
            $fns,
            $nodes,
            function($nodes, $fn) {
                if (exists($fn)) then
                    $fn($nodes)
                else
                    ()
            }
        )
    }
};

(:~
 : Execute a chain of node transformers.
 :)
declare function xf:do($nodes as node()*, $fns as array(*))
    as node()* {
    xf:do($fns)($nodes)
};

(:~
 : Compose a chain of node transformers.
 :)
declare function xf:do-each($fns as array(*))
    as function(node()*) as node()* {
    function($nodes as node()*) as node()* {
        for $node in $nodes
        return
            array:fold-left(
                $fns,
                $node,
                function($node, $fn) {
                if (exists($fn)) then
                    $fn($node)
                else
                    ()
                }
            )
    }
};

(:~
 : Execute a chain of node transformers.
 :)
declare function xf:do-each($nodes as node()*, $fns as array(*))
    as node()* {
    xf:do-each($fns)($nodes)
};

(: ================ node transformers ================ :)

(:~
 : Replace the content (child nodes) of the input node
 :)
declare function xf:content($content as node()*)
    as function(element()?) as element()? {
    function($element as element()?) as element()? {
        if (exists($element)) then
            element { node-name($element) } {
                $element/@*,
                $content
            }
        else
            $element
    }
};

declare function xf:content($element as element()?, $content as node()*)
    as element()? {
    xf:content($content)($element)
};

(:~
 : Only replace the content of the input element when
 : the content is not empty.
 :)
declare function xf:content-if($content as node()*)
    as function(element()?) as element()? {
    function($element as element()?) as element()? {
        if (exists($content) and exists($element)) then
            element { node-name($element) } {
                $element/@*,
                $content
            }
        else
            $element
    }
};

declare function xf:content-if($element as element()?, $content as node()*)
    as element()? {
    xf:content-if($content)($element)
};

(:~
 : Replace the current node.
 :)
declare function xf:replace($replacement as node()*)
    as function(node()*) as node()* {
    function($nodes as node()*) as node()* {
        if (exists($nodes)) then
            $replacement
        else
            $nodes
    }
};

declare function xf:replace($nodes as node()*, $replacement as node()*)
    as node()* {
    xf:replace($replacement)($nodes)
};

(:~
 : Only replace the input nodes when the replacement
 : is not empty.
 :)
declare function xf:replace-if($replacement as node()*)
    as function(node()*) as node()* {
    function($nodes as node()*) as node()* {
        if (exists($replacement) and exists($nodes)) then
            $replacement
        else
            $nodes
    }
};

declare function xf:replace-if($nodes as node()*, $replacement as node()*)
    as node()* {
    xf:replace-if($replacement)($nodes)
};

(:~
 : Inserts nodes before the current node.
 :)
declare function xf:before($before as node()*)
    as function(node()*) as node()* {
    function($nodes as node()*) as node()* {
        ($before, $nodes)
    }
};

declare function xf:before($nodes as node()*, $before as node()*)
    as node()* {
    xf:before($before)($nodes)
};

(:~
 : Inserts nodes after the current node.
 :)
declare function xf:after($after as node()*)
    as function(node()*) as node()* {
    function($nodes as node()*) as node()* {
        ($nodes, $after)
    }
};

declare function xf:after($nodes as node()*, $after as node()*)
    as node()* {
    xf:after($after)($nodes)
};

(:~
 : Inserts nodes as first child, before the current content.
 :)
declare function xf:append($append as node()*)
    as function(node()*) as node()* {
    xf:element-transformer(
        function($node as element()) as element() {
            element { node-name($node) } {
                ($node/(@*,node()), $append)
            }
        }
     (: HACK :)
    )(true())
};

(:~
 : Inserts nodes as last child, after the current content.
 :)
declare function xf:append($nodes as node()*, $append as node()*)
    as node()* {
    xf:append($append)($nodes)
};

(:~
 : Inserts nodes as last child, after the current content.
 :)
declare function xf:prepend($prepend as node()*)
    as function(node()*) as node()* {
    xf:element-transformer(
        function($node as element()) as element() {
            element { node-name($node) } {
                ($node/@*, $prepend, $node/node())
            }
        }
     (: HACK :)
    )(true())
};

(:~
 : Inserts nodes as last child, after the current content.
 :)
declare function xf:prepend($nodes as node()*, $prepend as node()*)
    as node()* {
    xf:prepend($prepend)($nodes)
};

(:~
 : Returns a node transformer that returns a text node with
 : the space normalized string value of a node.
 :)
declare function xf:text()
    as function(node()*) as node()* {
    function($nodes as node()*) as text()? {
        if (exists($nodes)) then
            text { normalize-space(string-join($nodes,'')) }
        else
            ()
    }
};

declare function xf:text($nodes as node()*)
    as text()? {
    xf:text()($nodes)
};

(:~
 : Set attributes using a map.
 :)
declare function xf:set-attr($attributes as item())
    as function(node()*) as node()* {
    let $attributes :=
        typeswitch ($attributes)
        case map(*)
        return
            map:for-each(
                $attributes,
                function($name,$value) {
                    attribute { $name } { $value }
                })
        case element()
        return $attributes/@*
        default
        return
            ()
    return
        xf:element-transformer(
            function($node as element()) as node()* {
                element { node-name($node) } {
                    $attributes,
                    for $att in $node/@*
                    where node-name($att) != $attributes/node-name()
                    return $att,
                    $node/node()
                }
            }
        )($attributes)
};

declare function xf:set-attr($nodes as node()*, $attributes as item())
    as node()* {
    xf:set-attr($attributes)($nodes)
};

(:~
 : Add one or more `$names` to a class attribute.
 :)
declare function xf:add-class($names as xs:string*)
    as function(node()*) as node()* {
    xf:element-transformer(
        function($node as element()) as node()* {
            element { node-name($node) } {
                $node/@*[not(name(.) = 'class')],
                attribute class {
                    string-join(
                        distinct-values(
                            tokenize(
                                string-join(($node/@class,$names),' '),
                                '\s+')),
                        ' ')
                },
                $node/node()
            }
        }
    )($names)
};

(:~
 : Add one or more `$names` to the class attribute of `$element`.
 : If it doesn't exist it is added.
 :)
declare function xf:add-class($nodes as node()*, $names as xs:string*)
    as node()* {
    xf:add-class($names)($nodes)
};

(:~
 : Remove one or more `$names` from the class attribute.
 : If the class attribute is empty after removing names it will be removed
 : from the element.
 :)
declare function xf:remove-class($names as xs:string*)
    as function(node()*) as node()* {
    xf:element-transformer(
        function($node as element()) as node()* {
            element { node-name($node) } {
                $node/@*[not(name(.) =  'class')],
                let $classes := distinct-values(
                    tokenize(($node/@class,'')[1],'\s+')[not(. = $names)])
                where exists($classes)
                return
                    attribute class { string-join($classes,' ') },
                $node/node()
            }
        }
    )($names)
};

(:~
 : Remove one or more `$names` from the class attribute of `$element`.
 : If the class attribute is empty after removing names it will be removed
 : from the element.
 :)
declare function xf:remove-class($nodes as node()*, $names as xs:string*)
    as node()* {
    xf:remove-class($names)($nodes)
};

(:~
 : Remove attributes.
 :)
declare function xf:remove-attr($attributes as item()*)
    as function(node()*) as node()* {
    let $attributes :=
        typeswitch ($attributes)
        case xs:string*
        return for $name in $attributes return attribute { $name } { '' }
        case element()
        return $attributes/@*
        case map(*)
        return
            map:for-each(
                $attributes,
                function($name,$value) {
                    attribute { $name } { '' }
            })
        default
        return ()
    return
        xf:element-transformer(
            function($node as element()) as node()* {
                element { node-name($node) } {
                    for $att in $node/@*
                    where not(node-name($att) = $attributes/node-name())
                    return $att
                }
            }
        )($attributes)
};

declare function xf:remove-attr($nodes as node()*, $names as item()*)
    as node()* {
    xf:remove-attr($names)($nodes)
};

(:~
 : Returns a selector step function that wraps nodes in
 : an element `$element`. An empty sequence will not be
 : wrapped.
 :)
declare function xf:wrap($element as element())
    as function(node()*) as element()? {
    function($nodes as node()*) as element()? {
        if (exists($nodes)) then
            element { node-name($element) } {
                $element/@*,
                $nodes
            }
        else
            ()
    }
};

(:~
 : Wraps `$nodes` in element `$node`. An empty sequence will
 : not be wrapped.
 :)
declare function xf:wrap($nodes as node()*, $element as element())
    as element()? {
    xf:wrap($element)($nodes)
};

(:~
 : Returns a node transformer that removes (unwraps) the
 : outer element of all nodes that are elements. Other nodes
 : are passed through unmodified.
 :
 : This function is safe for use as a node selector.
 :)
declare function xf:unwrap()
    as function(node()*) as node()* {
    xf:element-transformer(
        function($node as element()) as node()* {
            $node/node()
          (: FIXME: passing true() is a bit of a hack, because
             element-transformers check for empty arg even if they
             don't need one :)
        }
    )(true())
};

(:~
 : Unwraps all nodes that are elements.
 :)
declare function xf:unwrap($nodes as node()*)
    as node()* {
    xf:unwrap()($nodes)
};

declare function xf:xslt($stylesheet as item())
    as function(node()*) as node()* {
    xf:xslt($stylesheet, map {})
};

declare function xf:xslt($stylesheet as item(), $params as item())
    as function(node()*) as node()* {
    xf:element-transformer(
        function($node as element()) as node()* {
            xslt:transform($node, $stylesheet, $params)/*
        }
    )($params)
};

declare function xf:xslt($nodes as node()*, $stylesheet as item(), $params as item())
    as node()* {
    xf:xslt($stylesheet, $params)($nodes)
};

(:
 : Creates a generic element node transformer function.
 :)
declare function xf:element-transformer($transform as function(element()) as node()*)
    as function(*) {
    function($args as item()*) as function(*) {
        function($nodes as node()*) as node()* {
            if (exists($args)) then
                for $node in $nodes
                return
                    if ($node instance of element()) then
                        $transform($node)
                    else
                        $node
            else
                $nodes
        }
    }
};

(: ================ environment ================ :)

(:~
 : Sets up a default environment which can be customized.
 : Represents the default bindings for selecting nodes.
 : The context is set to $nodes and all it's descendant elements.
 : It also sets up a helper function $in to enable proper checks on tokenized
 : (space-delimited) attribute values such as @class.
 :)
declare function xf:environment() {
    map {
        'bindings': function($nodes as node()*) as map(*) {
            map {
                '': $nodes/descendant-or-self::node(),
                xs:QName('in'): function($att, $token) as xs:boolean {
                    $token = tokenize(string($att),'\s+')
                }
            }
        },
        'query': function($selector as xs:string) {
            'declare variable $in external; ' || $selector
        }
    }
};

declare function xf:expr-environment() {
    map {
        'bindings': function($nodes as node()*) as map(*) {
            map {
                '': $nodes,
                xs:QName('in'): function($att, $token) as xs:boolean {
                    $token = tokenize(string($att),'\s+')
                }
            }
        },
        'query': function($selector as xs:string) {
            'declare variable $in external; ' || $selector
        }
    }
};

(:~
 : Find matches for XPath expression string applied to passed in nodes.
 :)
declare function xf:select-all($selector as xs:string)
    as function(node()*) as node()* {
    xf:select-with-env($selector, xf:environment())
};

declare function xf:select-all($nodes as node()*, $selector as xs:string)
    as function(node()*) as node()* {
    xf:select-all($selector)($nodes)
};

declare function xf:select($selector as xs:string)
    as function(node()*) as node()* {
    xf:select-with-env($selector, xf:expr-environment())
};

declare function xf:select($nodes as node()*, $selector as xs:string)
    as function(node()*) as node()* {
    xf:select($selector)($nodes)
};

declare %private function xf:select-with-env($selector as xs:string, $env as map(*))
    as function(node()*) as node()* {
    let $query := $env('query')($selector)
    let $bindings := $env('bindings')
    return
        function($nodes as node()*) as node()* {
            xquery:eval($query, $bindings($nodes))
        }
};

(: ================ internal functions ================ :)

(:~
 : Copies nodes to output, and calls apply for
 : nodes that are wrapped inside <xf:apply>.
 :)
declare %private function xf:copy-nodes($nodes as node()*, $xform as map(*)*)
    as node()* {
    for $node in $nodes
    return
        if ($node/self::xf:apply) then
            xf:apply-nodes($node/(@*, node()), (), $xform)
        else if ($node instance of element()) then
            element { node-name($node) } {
                $node/@*,
                xf:copy-nodes($node/node(), $xform)
            }
        else if ($node instance of document-node()) then
            document {
                xf:copy-nodes($node/node(), $xform)
            }
        else
            $node
};

(:~
 : Applies nodes to output, but runs the template node transformer when it
 : encounters a node that was matched.
 :)
declare function xf:apply-nodes($nodes as node()*, $context as map(*)*, $xform as map(*)*)
    as node()* {
    for $node in $nodes
    let $context := (xf:match-templates($node, $xform), $context)
    let $match := xf:matched-template($node, $context)
    return
        if ($match instance of map(*)) then
            xf:copy-nodes($match('fn')($node), $xform)
        else if ($node instance of element()) then
            element { node-name($node) } {
                xf:apply-nodes($node/(@*, node()), $context, $xform)
            }
        else if ($node instance of document-node()) then
            document {
                xf:apply-nodes($node/node(), $context, $xform)
            }
        else
            $node
};

(:~
 : Apply to be used from within templates.
 : TODO: maybe rename to xf:apply-rules
 :)
declare function xf:apply($nodes as node()*)
    as element(xf:apply) {
    <xf:apply>{ $nodes }</xf:apply>
};

(:~
 : Find all templates matched by this node and adds the matched nodes
 : to the templates.
 :)
declare function xf:match-templates($node as node(), $xform as map(*)*)
    as map(*)* {
    fold-left(
        $xform,
        (),
        function($matched-templates as map(*)*, $template as map(*)) {
            let $matched-nodes := $template('select')($node)
            return
                if (exists($matched-nodes)) then
                    ($matched-templates, map:new(($template, map { 'nodes': $matched-nodes })))
                else
                    $matched-templates
        }
    )
};

(:~
 : Looks in the $context to find a template that was matched by this
 : node. First one found (most-specific) wins.
 :)
declare function xf:matched-template($node as node(), $context as map(*)*)
    as map(*)? {
    if (count($context) gt 0) then
        hof:until(
            function($context as map(*)*) {
                empty($context) or
                xf:is-node-in-sequence($node, head($context)('nodes')) },
            function($context as map(*)*) {
                tail($context) },
            $context
        )[1]
    else
        ()
};

declare %private function xf:comp-expression($expressions as item()*)
    as (function(node()*) as node()*)* {
    for $expression in $expressions
    return
        if ($expression instance of xs:string) then
            xf:select($expression)
        else
            $expression
};

(:~
 : Is node defined in seq?
 : @see http://www.xqueryfunctions.com/xq/functx_is-node-in-sequence.html
 :)
declare %private function xf:is-node-in-sequence($node as node()?, $seq as node()*)
    as xs:boolean {
    some $nodeInSeq in $seq satisfies $nodeInSeq is $node
};

(: ======== :)

(:~
 : TODO: NOT USED!
 :
 : Return matching nodes.
 :)
declare %private function xf:select-nodes($nodes as node()*, $selectors as function(*)*)
    as node()* {
    for $selector in $selectors
    return
        for $node in $nodes
        return
            $selector($node)
};

(:~
 : TODO: NOT USED!
 :
 : Find the first matching template for a node and return
 : it's node transformation function.
 :)
declare %private function xf:match-node($node as node(), $xform as map(*)*)
    as map(*)? {
    hof:until(
        function($templates as map(*)*) {
            let $is-match := head($templates)
            return
                empty($is-match) or
                ($is-match instance of map(*) and map:contains($is-match,'nodes'))
        },
        function($templates as map(*)*) {
            let $template := head($templates)
            let $matched-nodes := $template('select')($node)
            return
                (
                    if ($matched-nodes) then
                        map:new(($template, map { 'nodes': $matched-nodes }))
                    else
                        ()
                    ,
                    tail($templates)
                )
        },
        $xform
    )[1]
};

(:~
 : TODO: NOT USED!
 :
 : Find the first matching template for a node
 : and return a modified template that contains the matched nodes.
 :)
declare %private function xf:match-template($node as node(), $xform as map(*)*)
    as map(*)? {
    hof:until(
        function($templates as map(*)*) {
            let $is-match := head($templates)
            return
                empty($is-match) or
                ($is-match instance of map(*) and map:contains($is-match,'nodes'))
        },
        function($templates as map(*)*) {
            let $template := head($templates)
            let $matched-nodes := $template('select')($node)
            return
                (
                    if ($matched-nodes) then
                        map:new(($template, map { 'nodes': $matched-nodes }))
                    else
                        ()
                    ,
                    tail($templates)
                )
        },
        $xform
    )[1]
};

xquery version "3.0";

(:~
 : Origami templating.
 :
 : Requires Basex 8.0 20141219 or later.
 :
 : @version 0.4
 : @author Marc van Grootel
 : @see https://github.com/xokomola/origami
 :)

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

(:~
 : Load an HTML resource.
 :)
declare function xf:html-resource($url-or-path) {
    if (starts-with($url-or-path,'http:/')) then
        xf:fetch-html($url-or-path)
    else
        xf:parse-html($url-or-path)
};

(:~
 : Load an XML resource.
 :)
declare function xf:xml-resource($url-or-path) {
    doc($url-or-path)
};

(:~
 : Fetch and parse HTML given a URL.
 :)
declare function xf:fetch-html($url) {
    html:parse(fetch:binary($url))
};

(:~
 : Parse HTML from a filesystem path.
 :)
declare function xf:parse-html($path) {
    html:parse(file:read-binary($path))
};

(:~
 : Returns a Transformer function.
 :)
declare function xf:transform($templates as array(*)*)
    as function(node()*) as node()* {
    let $templates :=
        for $template in $templates
        return xf:match($template)
    return
        function($nodes as node()*) as node()* {
            xf:apply-nodes($nodes, (), $templates)
        }
};

(:~
 : Transform input, using the specified templates.
 :)
declare function xf:transform($nodes as node()*, $templates as array(*)*)
    as node()* {
    xf:transform($templates)($nodes)
};

(:~
 : Identity transformer.
 :)
declare function xf:transform() { xf:transform(()) };

(:~
 : Returns an extractor function that only returns selected nodes
 : only outermost, in document order and duplicates eliminated.
 :)
declare function xf:extract($selectors as array(*)*)
    as function(node()*) as node()* {
    xf:extract-outer($selectors)
};

(:~
 : Extracts nodes from input, using the specified selectors.
 :)
declare function xf:extract($nodes as node()*, $selectors as array(*)*)
    as node()* {
    xf:extract($selectors)($nodes)
};

(:~
 : Returns an extractor function that returns selected nodes,
 : only innermost, in document order and duplicates eliminitated.
 :
 : TODO: when using ['*',()] this should delete the element
 :
 : TODO: this version still suffers from the problem with transforms
 :       being done before the inner/outermost which means that
 :       they still frustrate the distinct/duplicate nodes stuff
 :)
declare function xf:extract-inner($selectors as array(*)*)
    as function(node()*) as node()* {
    let $selectors :=
        for $selector in $selectors
        return
            xf:at($selector)
    return
        function($nodes as node()*) as node()* {
            innermost($selectors($nodes))
        }
};

declare function xf:extract-inner($nodes as node()*, $selectors as array(*)*)
    as node()* {
    xf:extract-inner($selectors)($nodes)
};

(:~
 : Returns an extractor function that returns selected nodes,
 : only outermost, in document order and duplicates eliminated.
 :)
declare function xf:extract-outer($selectors as array(*)*)
    as function(node()*) as node()* {
    let $selectors :=
        for $selector in $selectors
        return xf:at($selector)
    return
        function($nodes as node()*) as node()* {
            outermost($selectors($nodes))
        }
};

declare function xf:extract-outer($nodes as node()*, $selectors as array(*)*)
    as node()* {
    xf:extract-outer($selectors)($nodes)
};

(:~
 : Defines a match template.
 :
 : A template takes a selector string or function and
 : a node transformation function or the items to return as
 : the template body.
 : Providing invalid matcher returns empty sequence.
 :)
declare function xf:match($template as array(*))
    as map(*)? {
    let $selector := xf:selector([array:head($template)])
    (: HACK: to work around an array:fold-left bug in 20141219 :)
    let $body := xf:do(array:filter($template,function($i) { not($i instance of xs:string) }))
    where array:size($template) gt 0
    return
        map {
            'select': $selector,
            'fn': $body
        }
};

declare function xf:at($steps as array(*))
    as function(node()*) as node()* {
    xf:selector($steps, xf:select-all#1)
};
(:~
 : Execute a chain of node selectors.
 :)
declare function xf:at($nodes as node()*, $selector as item()*) {
    xf:at($selector)($nodes)
};

(:~
 : Define a transformation that starts with selecting nodes with an
 : XPath expression.
 :)
declare %private function xf:selector($steps as array(*), $selector-fn as function(*))
    as function(node()*) as node()* {
    (: compile the steps :)
    let $steps :=
        array:fold-left(
            $steps,
            (),
            function($result, $step) {
                if ($step instance of xs:string) then
                    ($result, $selector-fn($step))
                else if ($step instance of function(*)) then
                    ($result, $step)
                else if ($step instance of node()*) then
                    ($result, function($node as node()*) as node()* { $step })
                else if ($step instance of empty-sequence()) then
                    function($node as node()*) as node()* { () }
                else
                    ($result, text { $step })
            }
        )
    return
        function($nodes as node()*) as node()* {
            for $selected in head($steps)($nodes)
            return
                fold-left(
                    tail($steps),
                    $selected,
                    function($result, $step) {
                        $step($result)
                    }
                )
        }
};

declare %private function xf:selector($steps as array(*))
    as function(node()*) as node()* {
    xf:selector($steps, xf:select-all#1)
};
(:~
 : Only nodes for which the chain of expressions evaluates to `true()`
 : are passed through.
 :
 : TODO: need to do proper xpath expression evaluation (not used descendent)
 :)
declare function xf:if($conditions as item()*)
    as function(node()*) as node()* {
    let $conditions := xf:comp-expression($conditions)
    return
        function($nodes as node()*) as node()* {
            fold-left(
                $conditions,
                $nodes,
                function($result, $step) {
                    if ($step($result)) then
                       $result
                    else
                        ()
                }
            )
        }
};

(:~
 : Filter nodes based on evaluating a chain of expressions, letting only
 : those nodes through for which it returns `true()`.
 :)
declare function xf:if($nodes as node()*, $conditions as item()*)
    as node()* {
    xf:if($conditions)($nodes)
};

(:~
 : Compose a chain of node transformers.
 :)
declare function xf:do($fns as array(*))
    as function(node()*) as node()* {
    function($nodes as node()*) as node()* {
        array:fold-left(
            $fns,
            $nodes,
            function($nodes, $fn) {
                if (exists($fn)) then
                    $fn($nodes)
                else
                    ()
            }
        )
    }
};

(:~
 : Execute a chain of node transformers.
 :)
declare function xf:do($nodes as node()*, $fns as array(*))
    as node()* {
    xf:do($fns)($nodes)
};

(:~
 : Compose a chain of node transformers.
 :)
declare function xf:do-each($fns as array(*))
    as function(node()*) as node()* {
    function($nodes as node()*) as node()* {
        for $node in $nodes
        return
            array:fold-left(
                $fns,
                $node,
                function($node, $fn) {
                if (exists($fn)) then
                    $fn($node)
                else
                    ()
                }
            )
    }
};

(:~
 : Execute a chain of node transformers.
 :)
declare function xf:do-each($nodes as node()*, $fns as array(*))
    as node()* {
    xf:do-each($fns)($nodes)
};

(: ================ node transformers ================ :)

(:~
 : Replace the content (child nodes) of the input node
 :)
declare function xf:content($content as node()*)
    as function(element()?) as element()? {
    function($element as element()?) as element()? {
        if (exists($element)) then
            element { node-name($element) } {
                $element/@*,
                $content
            }
        else
            $element
    }
};

declare function xf:content($element as element()?, $content as node()*)
    as element()? {
    xf:content($content)($element)
};

(:~
 : Only replace the content of the input element when
 : the content is not empty.
 :)
declare function xf:content-if($content as node()*)
    as function(element()?) as element()? {
    function($element as element()?) as element()? {
        if (exists($content) and exists($element)) then
            element { node-name($element) } {
                $element/@*,
                $content
            }
        else
            $element
    }
};

declare function xf:content-if($element as element()?, $content as node()*)
    as element()? {
    xf:content-if($content)($element)
};

(:~
 : Replace the current node.
 :)
declare function xf:replace($replacement as node()*)
    as function(node()*) as node()* {
    function($nodes as node()*) as node()* {
        if (exists($nodes)) then
            $replacement
        else
            $nodes
    }
};

declare function xf:replace($nodes as node()*, $replacement as node()*)
    as node()* {
    xf:replace($replacement)($nodes)
};

(:~
 : Only replace the input nodes when the replacement
 : is not empty.
 :)
declare function xf:replace-if($replacement as node()*)
    as function(node()*) as node()* {
    function($nodes as node()*) as node()* {
        if (exists($replacement) and exists($nodes)) then
            $replacement
        else
            $nodes
    }
};

declare function xf:replace-if($nodes as node()*, $replacement as node()*)
    as node()* {
    xf:replace-if($replacement)($nodes)
};

(:~
 : Inserts nodes before the current node.
 :)
declare function xf:before($before as node()*)
    as function(node()*) as node()* {
    function($nodes as node()*) as node()* {
        ($before, $nodes)
    }
};

declare function xf:before($nodes as node()*, $before as node()*)
    as node()* {
    xf:before($before)($nodes)
};

(:~
 : Inserts nodes after the current node.
 :)
declare function xf:after($after as node()*)
    as function(node()*) as node()* {
    function($nodes as node()*) as node()* {
        ($nodes, $after)
    }
};

declare function xf:after($nodes as node()*, $after as node()*)
    as node()* {
    xf:after($after)($nodes)
};

(:~
 : Inserts nodes as first child, before the current content.
 :)
declare function xf:append($append as node()*)
    as function(node()*) as node()* {
    xf:element-transformer(
        function($node as element()) as element() {
            element { node-name($node) } {
                ($node/(@*,node()), $append)
            }
        }
     (: HACK :)
    )(true())
};

(:~
 : Inserts nodes as last child, after the current content.
 :)
declare function xf:append($nodes as node()*, $append as node()*)
    as node()* {
    xf:append($append)($nodes)
};

(:~
 : Inserts nodes as last child, after the current content.
 :)
declare function xf:prepend($prepend as node()*)
    as function(node()*) as node()* {
    xf:element-transformer(
        function($node as element()) as element() {
            element { node-name($node) } {
                ($node/@*, $prepend, $node/node())
            }
        }
     (: HACK :)
    )(true())
};

(:~
 : Inserts nodes as last child, after the current content.
 :)
declare function xf:prepend($nodes as node()*, $prepend as node()*)
    as node()* {
    xf:prepend($prepend)($nodes)
};

(:~
 : Returns a node transformer that returns a text node with
 : the space normalized string value of a node.
 :)
declare function xf:text()
    as function(node()*) as node()* {
    function($nodes as node()*) as text()? {
        if (exists($nodes)) then
            text { normalize-space(string-join($nodes,'')) }
        else
            ()
    }
};

declare function xf:text($nodes as node()*)
    as text()? {
    xf:text()($nodes)
};

(:~
 : Set attributes using a map.
 :)
declare function xf:set-attr($attributes as item())
    as function(node()*) as node()* {
    let $attributes :=
        typeswitch ($attributes)
        case map(*)
        return
            map:for-each(
                $attributes,
                function($name,$value) {
                    attribute { $name } { $value }
                })
        case element()
        return $attributes/@*
        default
        return
            ()
    return
        xf:element-transformer(
            function($node as element()) as node()* {
                element { node-name($node) } {
                    $attributes,
                    for $att in $node/@*
                    where node-name($att) != $attributes/node-name()
                    return $att,
                    $node/node()
                }
            }
        )($attributes)
};

declare function xf:set-attr($nodes as node()*, $attributes as item())
    as node()* {
    xf:set-attr($attributes)($nodes)
};

(:~
 : Add one or more `$names` to a class attribute.
 :)
declare function xf:add-class($names as xs:string*)
    as function(node()*) as node()* {
    xf:element-transformer(
        function($node as element()) as node()* {
            element { node-name($node) } {
                $node/@*[not(name(.) = 'class')],
                attribute class {
                    string-join(
                        distinct-values(
                            tokenize(
                                string-join(($node/@class,$names),' '),
                                '\s+')),
                        ' ')
                },
                $node/node()
            }
        }
    )($names)
};

(:~
 : Add one or more `$names` to the class attribute of `$element`.
 : If it doesn't exist it is added.
 :)
declare function xf:add-class($nodes as node()*, $names as xs:string*)
    as node()* {
    xf:add-class($names)($nodes)
};

(:~
 : Remove one or more `$names` from the class attribute.
 : If the class attribute is empty after removing names it will be removed
 : from the element.
 :)
declare function xf:remove-class($names as xs:string*)
    as function(node()*) as node()* {
    xf:element-transformer(
        function($node as element()) as node()* {
            element { node-name($node) } {
                $node/@*[not(name(.) =  'class')],
                let $classes := distinct-values(
                    tokenize(($node/@class,'')[1],'\s+')[not(. = $names)])
                where exists($classes)
                return
                    attribute class { string-join($classes,' ') },
                $node/node()
            }
        }
    )($names)
};

(:~
 : Remove one or more `$names` from the class attribute of `$element`.
 : If the class attribute is empty after removing names it will be removed
 : from the element.
 :)
declare function xf:remove-class($nodes as node()*, $names as xs:string*)
    as node()* {
    xf:remove-class($names)($nodes)
};

(:~
 : Remove attributes.
 :)
declare function xf:remove-attr($attributes as item()*)
    as function(node()*) as node()* {
    let $attributes :=
        typeswitch ($attributes)
        case xs:string*
        return for $name in $attributes return attribute { $name } { '' }
        case element()
        return $attributes/@*
        case map(*)
        return
            map:for-each(
                $attributes,
                function($name,$value) {
                    attribute { $name } { '' }
            })
        default
        return ()
    return
        xf:element-transformer(
            function($node as element()) as node()* {
                element { node-name($node) } {
                    for $att in $node/@*
                    where not(node-name($att) = $attributes/node-name())
                    return $att
                }
            }
        )($attributes)
};

declare function xf:remove-attr($nodes as node()*, $names as item()*)
    as node()* {
    xf:remove-attr($names)($nodes)
};

(:~
 : Returns a selector step function that wraps nodes in
 : an element `$element`. An empty sequence will not be
 : wrapped.
 :)
declare function xf:wrap($element as element())
    as function(node()*) as element()? {
    function($nodes as node()*) as element()? {
        if (exists($nodes)) then
            element { node-name($element) } {
                $element/@*,
                $nodes
            }
        else
            ()
    }
};

(:~
 : Wraps `$nodes` in element `$node`. An empty sequence will
 : not be wrapped.
 :)
declare function xf:wrap($nodes as node()*, $element as element())
    as element()? {
    xf:wrap($element)($nodes)
};

(:~
 : Returns a node transformer that removes (unwraps) the
 : outer element of all nodes that are elements. Other nodes
 : are passed through unmodified.
 :
 : This function is safe for use as a node selector.
 :)
declare function xf:unwrap()
    as function(node()*) as node()* {
    xf:element-transformer(
        function($node as element()) as node()* {
            $node/node()
          (: FIXME: passing true() is a bit of a hack, because
             element-transformers check for empty arg even if they
             don't need one :)
        }
    )(true())
};

(:~
 : Unwraps all nodes that are elements.
 :)
declare function xf:unwrap($nodes as node()*)
    as node()* {
    xf:unwrap()($nodes)
};

declare function xf:xslt($stylesheet as item())
    as function(node()*) as node()* {
    xf:xslt($stylesheet, map {})
};

declare function xf:xslt($stylesheet as item(), $params as item())
    as function(node()*) as node()* {
    xf:element-transformer(
        function($node as element()) as node()* {
            xslt:transform($node, $stylesheet, $params)/*
        }
    )($params)
};

declare function xf:xslt($nodes as node()*, $stylesheet as item(), $params as item())
    as node()* {
    xf:xslt($stylesheet, $params)($nodes)
};

(:
 : Creates a generic element node transformer function.
 :)
declare function xf:element-transformer($transform as function(element()) as node()*)
    as function(*) {
    function($args as item()*) as function(*) {
        function($nodes as node()*) as node()* {
            if (exists($args)) then
                for $node in $nodes
                return
                    if ($node instance of element()) then
                        $transform($node)
                    else
                        $node
            else
                $nodes
        }
    }
};

(: ================ environment ================ :)

(:~
 : Sets up a default environment which can be customized.
 : Represents the default bindings for selecting nodes.
 : The context is set to $nodes and all it's descendant elements.
 : It also sets up a helper function $in to enable proper checks on tokenized
 : (space-delimited) attribute values such as @class.
 :)
declare function xf:environment() {
    map {
        'bindings': function($nodes as node()*) as map(*) {
            map {
                '': $nodes/descendant-or-self::node(),
                xs:QName('in'): function($att, $token) as xs:boolean {
                    $token = tokenize(string($att),'\s+')
                }
            }
        },
        'query': function($selector as xs:string) {
            'declare variable $in external; ' || $selector
        }
    }
};

declare function xf:expr-environment() {
    map {
        'bindings': function($nodes as node()*) as map(*) {
            map {
                '': $nodes,
                xs:QName('in'): function($att, $token) as xs:boolean {
                    $token = tokenize(string($att),'\s+')
                }
            }
        },
        'query': function($selector as xs:string) {
            'declare variable $in external; ' || $selector
        }
    }
};

(:~
 : Find matches for XPath expression string applied to passed in nodes.
 :)
declare function xf:select-all($selector as xs:string)
    as function(node()*) as node()* {
    xf:select-with-env($selector, xf:environment())
};

declare function xf:select-all($nodes as node()*, $selector as xs:string)
    as function(node()*) as node()* {
    xf:select-all($selector)($nodes)
};

declare function xf:select($selector as xs:string)
    as function(node()*) as node()* {
    xf:select-with-env($selector, xf:expr-environment())
};

declare function xf:select($nodes as node()*, $selector as xs:string)
    as function(node()*) as node()* {
    xf:select($selector)($nodes)
};

declare %private function xf:select-with-env($selector as xs:string, $env as map(*))
    as function(node()*) as node()* {
    let $query := $env('query')($selector)
    let $bindings := $env('bindings')
    return
        function($nodes as node()*) as node()* {
            xquery:eval($query, $bindings($nodes))
        }
};

(: ================ internal functions ================ :)

(:~
 : Copies nodes to output, and calls apply for
 : nodes that are wrapped inside <xf:apply>.
 :)
declare %private function xf:copy-nodes($nodes as node()*, $xform as map(*)*)
    as node()* {
    for $node in $nodes
    return
        if ($node/self::xf:apply) then
            xf:apply-nodes($node/(@*, node()), (), $xform)
        else if ($node instance of element()) then
            element { node-name($node) } {
                $node/@*,
                xf:copy-nodes($node/node(), $xform)
            }
        else if ($node instance of document-node()) then
            document {
                xf:copy-nodes($node/node(), $xform)
            }
        else
            $node
};

(:~
 : Applies nodes to output, but runs the template node transformer when it
 : encounters a node that was matched.
 :)
declare function xf:apply-nodes($nodes as node()*, $context as map(*)*, $xform as map(*)*)
    as node()* {
    for $node in $nodes
    let $context := (xf:match-templates($node, $xform), $context)
    let $match := xf:matched-template($node, $context)
    return
        if ($match instance of map(*)) then
            xf:copy-nodes($match('fn')($node), $xform)
        else if ($node instance of element()) then
            element { node-name($node) } {
                xf:apply-nodes($node/(@*, node()), $context, $xform)
            }
        else if ($node instance of document-node()) then
            document {
                xf:apply-nodes($node/node(), $context, $xform)
            }
        else
            $node
};

(:~
 : Apply to be used from within templates.
 : TODO: maybe rename to xf:apply-rules
 :)
declare function xf:apply($nodes as node()*)
    as element(xf:apply) {
    <xf:apply>{ $nodes }</xf:apply>
};

(:~
 : Find all templates matched by this node and adds the matched nodes
 : to the templates.
 :)
declare function xf:match-templates($node as node(), $xform as map(*)*)
    as map(*)* {
    fold-left(
        $xform,
        (),
        function($matched-templates as map(*)*, $template as map(*)) {
            let $matched-nodes := $template('select')($node)
            return
                if (exists($matched-nodes)) then
                    ($matched-templates, map:new(($template, map { 'nodes': $matched-nodes })))
                else
                    $matched-templates
        }
    )
};

(:~
 : Looks in the $context to find a template that was matched by this
 : node. First one found (most-specific) wins.
 :)
declare function xf:matched-template($node as node(), $context as map(*)*)
    as map(*)? {
    if (count($context) gt 0) then
        hof:until(
            function($context as map(*)*) {
                empty($context) or
                xf:is-node-in-sequence($node, head($context)('nodes')) },
            function($context as map(*)*) {
                tail($context) },
            $context
        )[1]
    else
        ()
};

declare %private function xf:comp-expression($expressions as item()*)
    as (function(node()*) as node()*)* {
    for $expression in $expressions
    return
        if ($expression instance of xs:string) then
            xf:select($expression)
        else
            $expression
};

(:~
 : Is node defined in seq?
 : @see http://www.xqueryfunctions.com/xq/functx_is-node-in-sequence.html
 :)
declare %private function xf:is-node-in-sequence($node as node()?, $seq as node()*)
    as xs:boolean {
    some $nodeInSeq in $seq satisfies $nodeInSeq is $node
};

(: ======== :)

(:~
 : TODO: NOT USED!
 :
 : Return matching nodes.
 :)
declare %private function xf:select-nodes($nodes as node()*, $selectors as function(*)*)
    as node()* {
    for $selector in $selectors
    return
        for $node in $nodes
        return
            $selector($node)
};

(:~
 : TODO: NOT USED!
 :
 : Find the first matching template for a node and return
 : it's node transformation function.
 :)
declare %private function xf:match-node($node as node(), $xform as map(*)*)
    as map(*)? {
    hof:until(
        function($templates as map(*)*) {
            let $is-match := head($templates)
            return
                empty($is-match) or
                ($is-match instance of map(*) and map:contains($is-match,'nodes'))
        },
        function($templates as map(*)*) {
            let $template := head($templates)
            let $matched-nodes := $template('select')($node)
            return
                (
                    if ($matched-nodes) then
                        map:new(($template, map { 'nodes': $matched-nodes }))
                    else
                        ()
                    ,
                    tail($templates)
                )
        },
        $xform
    )[1]
};

(:~
 : TODO: NOT USED!
 :
 : Find the first matching template for a node
 : and return a modified template that contains the matched nodes.
 :)
declare %private function xf:match-template($node as node(), $xform as map(*)*)
    as map(*)? {
    hof:until(
        function($templates as map(*)*) {
            let $is-match := head($templates)
            return
                empty($is-match) or
                ($is-match instance of map(*) and map:contains($is-match,'nodes'))
        },
        function($templates as map(*)*) {
            let $template := head($templates)
            let $matched-nodes := $template('select')($node)
            return
                (
                    if ($matched-nodes) then
                        map:new(($template, map { 'nodes': $matched-nodes }))
                    else
                        ()
                    ,
                    tail($templates)
                )
        },
        $xform
    )[1]
};


Let each WG identify its head component - makes it easier to read the data.

declare variable $pos := //parts-of-speech;
declare variable $morph := //morphology;

declare function local:morph-description($tag, $category)
{
   $morph/field[@tag=$category]/value[@tag=$tag]/@summary ! string(.)
};

declare function local:number($morph as xs:string)
{
  let $tag := substring($morph,2,1)
  where $tag != "-"
  return
    attribute number {
      local:morph-description($tag, "number")
    }
};

declare function local:person($morph as xs:string)
{
  let $tag := substring($morph,1,1)
  where $tag != "-"
  return
    attribute person {
      tokenize(local:morph-description($tag, "person"))[1]
    }
};

declare function local:gender($morph as xs:string)
{
  let $tag := substring($morph,6,1)
  where $tag != "-"
  return
    attribute gender {
      local:morph-description($tag,"gender")
    }
};

declare function local:case($morph as xs:string)
{
  let $tag := substring($morph,7,1)
  where $tag != "-"
  return
    attribute case {
      local:morph-description($tag,"case")
    }
};

declare function local:tense($morph as xs:string)
{
  let $tag := substring($morph,3,1)
  where $tag != "-"
  return
    attribute tense {
      local:morph-description($tag,"tense")
    }
};

declare function local:voice($morph as xs:string)
{
  let $tag := substring($morph,5,1)
  where $tag != "-"
  return
    attribute voice {
      local:morph-description($tag,"voice")
    }
};

declare function local:mood($morph as xs:string)
{
  let $tag := substring($morph,4,1)
  where $tag != "-"
  return
    attribute mood {
      local:morph-description($tag,"mood")
    }
};

declare function local:degree($morph as xs:string)
{
  let $tag := substring($morph,8,1)
  where $tag != "-"
  return
    attribute degree {
      local:morph-description($tag,"degree")
    }
};

declare function local:strength($morph as xs:string)
{
  let $tag := substring($morph,9,1)
  where $tag != "-"
  return
    attribute strength {
      local:morph-description($tag,"strength")
    }
};

declare function local:inflection($morph as xs:string)
{
  let $tag := substring($morph,10,1)
  where $tag != "-"
  return
    attribute inflection {
      local:morph-description($tag,"inflection")
    }
};

declare function local:morphology($t)
{
  let $morph := string($t/@morphology)
  where $morph
  return (
    local:number($morph),
    local:person($morph),
    local:gender($morph),
    local:case($morph),
    local:tense($morph),
    local:voice($morph),
    local:mood($morph),
    local:degree($morph),
    local:strength($morph),
    local:inflection($morph)
  )
};

declare function local:class($t)
{
  let $description :=  string($pos/value[@tag = $t/@part-of-speech]/@summary)
  let $class :=
    switch ($description)
      case "interrogative adverb" return "adverb"
      case "relative adverb" return "adverb"
      case "common noun" return "noun"
      case "proper noun" return "noun"
      case "cardinal numeral" return "numeral"
      case "ordinal numeral" return "numeral"
      case "demonstrative pronoun" return "pronoun"
      case "indefinite pronoun" return "pronoun"
      case "interrogative pronoun" return "pronoun"
      case "relative pronoun" return "pronoun"
      case "personal pronoun" return "pronoun"
      case "personal reflexive pronoun" return "pronoun"
      case "possessive pronoun" return "pronoun"
      case "possessive reflexive pronoun" return "pronoun"
      case "reciprocal pronoun" return "pronoun"
      case "" return ()
      default return $description
  let $type :=
    switch ($description)
      case "interrogative adverb" return "interrogative"
      case "relative adverb" return "relative"
      case "common noun" return "common"
      case "proper noun" return "proper"
      case "cardinal numeral" return "cardinal"
      case "ordinal numeral" return "ordinal"
      case "demonstrative pronoun" return "demonstrative"
      case "indefinite pronoun" return "indefinite"
      case "interrogative pronoun" return "interrogative"
      case "relative pronoun" return "relative"
      case "personal pronoun" return "personal"
      case "personal reflexive pronoun" return "personal relative"
      case "possessive pronoun" return "possessive"
      case "possessive reflexive pronoun" return "possessive reflexive"
      case "reciprocal pronoun" return "reciprocal"
      default return ()
  return
    (
      $class ! attribute class {$class},
      $type ! attribute type {$type}
    )
};

declare function local:token($t)
{
  <w>
    {
      local:class($t),
      attribute role {$t/@relation},
      local:morphology($t),
      attribute id {$t/@id},
      $t/@head-id ! attribute head-id {$t/@head-id }
    }
    {
      string($t/@form)
    }
  </w>,
  $t/@presentation-after[. != ' '] ! <pc>{string(.)}</pc>
};

declare function local:unwrap($t, $stok)
{
  let $children :=  $stok[@head-id = $t/@id]
  let $seq := ($children | $t)/.
  return
    if ($children)
    then
      <wg role="{$t/@relation}" head="{$t/@id}">
        {
          for $s in $seq
          return
            if ($s is $t)
            then local:token($t)
            else local:unwrap($s, $stok)
        }
      </wg>
    else local:token($t)
};

declare function local:sentence($s)
{
  <sentence>
    {
      attribute id { $s/@id }
    }
    {
      let $stok := $s//token
      for $t in $stok[not(@head-id)]
      return local:unwrap($t, $stok)
    }
  </sentence>
};

<?xml-stylesheet href="treedown.css"?>,
<?xml-stylesheet href="boxwood.css"?>,
<book>
  {
    for $s in //sentence
    return local:sentence($s)
  }
</book>

declare variable $pos := //parts-of-speech;
declare variable $morph := //morphology;

declare function local:morph-description($tag, $category)
{
   $morph/field[@tag=$category]/value[@tag=$tag]/@summary ! string(.)
};

declare function local:number($morph as xs:string)
{
  let $tag := substring($morph,2,1)
  where $tag != "-"
  return
    attribute number {
      local:morph-description($tag, "number")
    }
};

declare function local:person($morph as xs:string)
{
  let $tag := substring($morph,1,1)
  where $tag != "-"
  return
    attribute person {
      tokenize(local:morph-description($tag, "person"))[1]
    }
};

declare function local:gender($morph as xs:string)
{
  let $tag := substring($morph,6,1)
  where $tag != "-"
  return
    attribute gender {
      local:morph-description($tag,"gender")
    }
};

declare function local:case($morph as xs:string)
{
  let $tag := substring($morph,7,1)
  where $tag != "-"
  return
    attribute case {
      local:morph-description($tag,"case")
    }
};

declare function local:tense($morph as xs:string)
{
  let $tag := substring($morph,3,1)
  where $tag != "-"
  return
    attribute tense {
      local:morph-description($tag,"tense")
    }
};

declare function local:voice($morph as xs:string)
{
  let $tag := substring($morph,5,1)
  where $tag != "-"
  return
    attribute voice {
      local:morph-description($tag,"voice")
    }
};

declare function local:mood($morph as xs:string)
{
  let $tag := substring($morph,4,1)
  where $tag != "-"
  return
    attribute mood {
      local:morph-description($tag,"mood")
    }
};

declare function local:degree($morph as xs:string)
{
  let $tag := substring($morph,8,1)
  where $tag != "-"
  return
    attribute degree {
      local:morph-description($tag,"degree")
    }
};

declare function local:strength($morph as xs:string)
{
  let $tag := substring($morph,9,1)
  where $tag != "-"
  return
    attribute strength {
      local:morph-description($tag,"strength")
    }
};

declare function local:inflection($morph as xs:string)
{
  let $tag := substring($morph,10,1)
  where $tag != "-"
  return
    attribute inflection {
      local:morph-description($tag,"inflection")
    }
};

declare function local:morphology($t)
{
  let $morph := string($t/@morphology)
  where $morph
  return (
    local:number($morph),
    local:person($morph),
    local:gender($morph),
    local:case($morph),
    local:tense($morph),
    local:voice($morph),
    local:mood($morph),
    local:degree($morph),
    local:strength($morph),
    local:inflection($morph)
  )
};

declare function local:class($t)
{
  let $description :=  string($pos/value[@tag = $t/@part-of-speech]/@summary)
  let $class :=
    switch ($description)
      case "interrogative adverb" return "adverb"
      case "relative adverb" return "adverb"
      case "common noun" return "noun"
      case "proper noun" return "noun"
      case "cardinal numeral" return "numeral"
      case "ordinal numeral" return "numeral"
      case "demonstrative pronoun" return "pronoun"
      case "indefinite pronoun" return "pronoun"
      case "interrogative pronoun" return "pronoun"
      case "relative pronoun" return "pronoun"
      case "personal pronoun" return "pronoun"
      case "personal reflexive pronoun" return "pronoun"
      case "possessive pronoun" return "pronoun"
      case "possessive reflexive pronoun" return "pronoun"
      case "reciprocal pronoun" return "pronoun"
      case "" return ()
      default return $description
  let $type :=
    switch ($description)
      case "interrogative adverb" return "interrogative"
      case "relative adverb" return "relative"
      case "common noun" return "common"
      case "proper noun" return "proper"
      case "cardinal numeral" return "cardinal"
      case "ordinal numeral" return "ordinal"
      case "demonstrative pronoun" return "demonstrative"
      case "indefinite pronoun" return "indefinite"
      case "interrogative pronoun" return "interrogative"
      case "relative pronoun" return "relative"
      case "personal pronoun" return "personal"
      case "personal reflexive pronoun" return "personal relative"
      case "possessive pronoun" return "possessive"
      case "possessive reflexive pronoun" return "possessive reflexive"
      case "reciprocal pronoun" return "reciprocal"
      default return ()
  return
    (
      $class ! attribute class {$class},
      $type ! attribute type {$type}
    )
};

declare function local:token($t)
{
  <w>
    {
      local:class($t),
      attribute role {$t/@relation},
      local:morphology($t),
      attribute id {$t/@id},
      $t/@head-id ! attribute head-id {$t/@head-id }
    }
    {
      string($t/@form)
    }
  </w>,
  $t/@presentation-after[. != ' '] ! <pc>{string(.)}</pc>
};

declare function local:unwrap($t, $stok)
{
  let $children :=  $stok[@head-id = $t/@id]
  let $seq := ($children | $t)/.
  return
    if ($children)
    then
      <wg role="{$t/@relation}">
        {
          for $s in $seq
          return
            if ($s is $t)
            then local:token($t)
            else local:unwrap($s, $stok)
        }
      </wg>
    else local:token($t)
};

declare function local:sentence($s)
{
  <sentence>
    {
      attribute id { $s/@id }
    }
    {
      let $stok := $s//token
      for $t in $stok[not(@head-id)]
      return local:unwrap($t, $stok)
    }
  </sentence>
};

<?xml-stylesheet href="treedown.css"?>,
<?xml-stylesheet href="boxwood.css"?>,
<book>
  {
    for $s in //sentence
    return local:sentence($s)
  }
</book>


Better generation of the <expected> element generated when an XQTS error occurs

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

declare namespace xqts="http://exist-db.org/xquery/xqts";
declare namespace catalog="http://www.w3.org/2005/02/query-test-XQTSCatalog";

import module namespace util="http://exist-db.org/xquery/util";
import module namespace xdb="http://exist-db.org/xquery/xmldb";
import module namespace xdiff="http://exist-db.org/xquery/xmldiff";

(:~ ----------------------------------------------------------------------------------------
     W3C XQuery Test Suite

     This is the main module for running the XQTS on eXist. You can either
     run the whole test suite, a specific test group or a single test case.

     Setup:

     * Make sure the XmlDiff module is registered in conf.xml

     * Change the $xqts:XQTS_HOME variable below to point to the directory into
     which you unzipped the XQTS sources.

     * Create a collection /db/XQTS in the database.

     * From the XQTS directory, upload XQTSCatalog.xml into the created
     collection.

     * Upload the "TestSources" directory so the source docs can be found
     in /db/XQTS/TestSources.

     * Run this script with the client.
     ------------------------------------------------------------------------------------------- :)
declare variable $xqts:XQTS_HOME { "file:///d:/Data/XQTS/" };

declare function xqts:initialize() as empty() {
    let $output-coll := xdb:create-collection("/db/XQTS", "test-results")
    let $dummy := xdb:store("/db/XQTS/test-results", "results.xml", <test-result failed="0" passed="0"/>)
    return ()
};

declare function xqts:get-query($case as element(catalog:test-case)) {
   let $query-name := $case//catalog:query/@name
   let $path := concat( $xqts:XQTS_HOME, "Queries/XQuery/", $case/@FilePath, $query-name, ".xq" )
   let $xq-string := util:file-read($path)
   return $xq-string
};

declare function xqts:print-result($test-name as xs:string, $passed as xs:boolean, $query as xs:string,
    $result as item()*, $expected as item()*, $case as element(catalog:test-case)) as element() {
    <test-case name="{$test-name}" result="{if ($passed) then 'pass' else 'fail'}">
    {
        if (not($passed)) then (
            <result>{$result}</result>,
            if ($expected instance of element() and count($expected/*) > 10) then
            	<expected truncated="">{$expected/*[position() < 10]}</expected>
            else
                <expected>{$expected}</expected>,
            (: element {$case/catalog:input-file/@variable} { xqts:getInputValue($case) }, :)
            <query>{$query}</query>
        ) else ()
    }
    </test-case>
};

declare function xqts:normalize-text($result as item()*) as xs:string {
    let $str := string-join($result, " ")
    return
        (: Remove leading and trailing whitespace :)
        replace(replace($str, "^\s+", ""), "\s+$", "")
};

declare function xqts:check-output($query as xs:string, $result as item()*, $case as element(catalog:test-case)) {
    let $output := $case/catalog:output-file[last()]
    return
        (: Comparison method: "Text" :)
        if ($output/@compare eq "Text") then
            let $text := util:file-read(concat($xqts:XQTS_HOME, "ExpectedTestResults/", $case/@FilePath,
                "/", $output/text()))
            let $test := xqts:normalize-text($text) eq xqts:normalize-text($result)
            return
                xqts:print-result($case/@name, $test, $query, $result, $text, $case)
        (: Comparison method: "XML" :)
        else if ($output/@compare eq "XML") then
            let $filePath := concat($xqts:XQTS_HOME, "ExpectedTestResults/", $case/@FilePath,
                $output/text())
            let $expected := doc(xdb:store("/db", "temp.xml", xs:anyURI($filePath), "text/xml"))
            let $test := xdiff:compare($expected, $result)
            return
                xqts:print-result($case/@name, $test, $query, $result, $expected, $case)
        (: Comparison method: "Fragment" :)
        else if ($output/@compare eq "Fragment") then
            let $filePath := concat($xqts:XQTS_HOME, "ExpectedTestResults/", $case/@FilePath, $output/text())
            let $expectedFrag := util:file-read($filePath)
            let $xmlFrag := concat("<f>", $expectedFrag, "</f>")
            let $log := util:log("DEBUG", ("Frag stored: ", $xmlFrag))
            let $expected := doc(xdb:store("/db", "temp.xml", $xmlFrag, "text/xml"))
            let $test := xdiff:compare($expected, <f>{$result}</f>)
            return
                xqts:print-result($case/@name, $test, $query, $result, $expected, $case)
        (: Don't know how to compare :)
        else
            <error test="{$case/@name}">Unknown comparison method: {$output/@compare}.</error>
};

declare function xqts:run-test-case( $case as element(catalog:test-case)) as item()* {
   let $query := xqts:get-query($case)
   let $context :=
       <static-context>
       {
           for $input in $case/catalog:input-file
           return
               <variable name="{$input/@variable}">{xqts:get-input-value($input)}</variable>
       }
       </static-context>
   let $result :=
       util:catch("java.lang.Exception",
           let $result :=
               util:eval-with-context($query, $context, false())
           return
               xqts:check-output($query, $result, $case),
           if (exists($case/catalog:expected-error)) then
               <test-case name="{$case/@name}" result="pass"/>
           else
               <test-case name="{$case/@name}" result="fail">
                   <exception>{$util:exception-message}</exception>
                   <query>{$query}</query>
               </test-case>
       )
   return $result
};

declare function xqts:finish() as empty() {
    let $result := doc("/db/XQTS/test-results/results.xml")/test-result
    let $passed := count($result//test-case[@result = 'pass'])
    let $failed := count($result//test-case[@result = 'fail'])
    return (
        update value $result/@passed with xs:int($passed),
        update value $result/@failed with xs:int($failed)
    )
};

declare function xqts:run-single-test-case($case as element(catalog:test-case),
    $group as element()?) as empty() {
    let $result := xqts:run-test-case($case)
    return
        if ($group) then
            update insert $result into $group
        else
            update insert $result into doc("/db/XQTS/test-results/results.xml")/test-result
};

declare function xqts:run-test-group($group as element(catalog:test-group),
    $parent as element()?) as empty() {
    update insert <test-group name="{$group/@name}">{$group/catalog:GroupInfo}</test-group>
        into $parent,
    let $newGroup := $parent/test-group[last()]
    return (
        for $test in $group/catalog:test-case
        let $log := util:log("DEBUG", ("Running test case: ", string($test/@name)))
        return
            xqts:run-single-test-case($test, $newGroup),
        for $childGroup in $group/catalog:test-group
        let $log := util:log("DEBUG", ("Entering group: ", string($childGroup/@name)))
        return
            xqts:run-test-group($childGroup, $newGroup)
    )
};

declare function xqts:test-single($name as xs:string) as empty() {
    let $test := //catalog:test-case[@name = $name]
    return
        xqts:run-single-test-case($test, collection("/db/XQTS/test-results")/test-result)
};

declare function xqts:test-group($groupName as xs:string) as empty() {
    let $group := //catalog:test-group[@name = $groupName]
    return
        xqts:run-test-group($group, collection("/db/XQTS/test-results")/test-result)
};

declare function xqts:test-all() as empty() {
    for $test in /catalog:test-suite/catalog:test-group
    return
        xqts:test-group($test/@name)
};

declare function xqts:get-input-value($input as element(catalog:input-file)) as item()* {
   if ($input eq "emptydoc") then
       ()
   else (
       let $source := root($input)//catalog:source[@ID = $input/text()]
       return
           if (empty($source)) then
               concat("no input found: ", $input/text())
           else
               doc(concat("/db/XQTS/", $source/@FileName))
   )
};

xqts:initialize(),
(: xqts:test-single("Axes001"), :)
xqts:test-group("MinimalConformance"),
(: xqts:test-all(), :)
xqts:finish(),
doc("/db/XQTS/test-results/results.xml")

declare namespace xqts="http://exist-db.org/xquery/xqts";
declare namespace catalog="http://www.w3.org/2005/02/query-test-XQTSCatalog";

import module namespace util="http://exist-db.org/xquery/util";
import module namespace xdb="http://exist-db.org/xquery/xmldb";
import module namespace xdiff="http://exist-db.org/xquery/xmldiff";

(:~ ----------------------------------------------------------------------------------------
     W3C XQuery Test Suite

     This is the main module for running the XQTS on eXist. You can either
     run the whole test suite, a specific test group or a single test case.

     Setup:

     * Make sure the XmlDiff module is registered in conf.xml

     * Change the $xqts:XQTS_HOME variable below to point to the directory into
     which you unzipped the XQTS sources.

     * Create a collection /db/XQTS in the database.

     * From the XQTS directory, upload XQTSCatalog.xml into the created
     collection.

     * Upload the "TestSources" directory so the source docs can be found
     in /db/XQTS/TestSources.

     * Run this script with the client.
     ------------------------------------------------------------------------------------------- :)
declare variable $xqts:XQTS_HOME { "file:///d:/Data/XQTS/" };

declare function xqts:initialize() as empty() {
    let $output-coll := xdb:create-collection("/db/XQTS", "test-results")
    let $dummy := xdb:store("/db/XQTS/test-results", "results.xml", <test-result failed="0" passed="0"/>)
    return ()
};

declare function xqts:get-query($case as element(catalog:test-case)) {
   let $query-name := $case//catalog:query/@name
   let $path := concat( $xqts:XQTS_HOME, "Queries/XQuery/", $case/@FilePath, $query-name, ".xq" )
   let $xq-string := util:file-read($path)
   return $xq-string
};

declare function xqts:print-result($test-name as xs:string, $passed as xs:boolean, $query as xs:string,
    $result as item()*, $expected as item()*, $case as element(catalog:test-case)) as element() {
    <test-case name="{$test-name}" result="{if ($passed) then 'pass' else 'fail'}">
    {
        if (not($passed)) then (
            <result>{$result}</result>,
            if ($expected instance of element() and count($expected/*) < 10) then
                <expected>{$expected}</expected>
            else
                (),
            (: element {$case/catalog:input-file/@variable} { xqts:getInputValue($case) }, :)
            <query>{$query}</query>
        ) else ()
    }
    </test-case>
};

declare function xqts:normalize-text($result as item()*) as xs:string {
    let $str := string-join($result, " ")
    return
        (: Remove leading and trailing whitespace :)
        replace(replace($str, "^\s+", ""), "\s+$", "")
};

declare function xqts:check-output($query as xs:string, $result as item()*, $case as element(catalog:test-case)) {
    let $output := $case/catalog:output-file[last()]
    return
        (: Comparison method: "Text" :)
        if ($output/@compare eq "Text") then
            let $text := util:file-read(concat($xqts:XQTS_HOME, "ExpectedTestResults/", $case/@FilePath,
                "/", $output/text()))
            let $test := xqts:normalize-text($text) eq xqts:normalize-text($result)
            return
                xqts:print-result($case/@name, $test, $query, $result, $text, $case)
        (: Comparison method: "XML" :)
        else if ($output/@compare eq "XML") then
            let $filePath := concat($xqts:XQTS_HOME, "ExpectedTestResults/", $case/@FilePath,
                $output/text())
            let $expected := doc(xdb:store("/db", "temp.xml", xs:anyURI($filePath), "text/xml"))
            let $test := xdiff:compare($expected, $result)
            return
                xqts:print-result($case/@name, $test, $query, $result, $expected, $case)
        (: Comparison method: "Fragment" :)
        else if ($output/@compare eq "Fragment") then
            let $filePath := concat($xqts:XQTS_HOME, "ExpectedTestResults/", $case/@FilePath, $output/text())
            let $expectedFrag := util:file-read($filePath)
            let $xmlFrag := concat("<f>", $expectedFrag, "</f>")
            let $log := util:log("DEBUG", ("Frag stored: ", $xmlFrag))
            let $expected := doc(xdb:store("/db", "temp.xml", $xmlFrag, "text/xml"))
            let $test := xdiff:compare($expected, <f>{$result}</f>)
            return
                xqts:print-result($case/@name, $test, $query, $result, $expected, $case)
        (: Don't know how to compare :)
        else
            <error test="{$case/@name}">Unknown comparison method: {$output/@compare}.</error>
};

declare function xqts:run-test-case( $case as element(catalog:test-case)) as item()* {
   let $query := xqts:get-query($case)
   let $context :=
       <static-context>
       {
           for $input in $case/catalog:input-file
           return
               <variable name="{$input/@variable}">{xqts:get-input-value($input)}</variable>
       }
       </static-context>
   let $result :=
       util:catch("java.lang.Exception",
           let $result :=
               util:eval-with-context($query, $context, false())
           return
               xqts:check-output($query, $result, $case),
           if (exists($case/catalog:expected-error)) then
               <test-case name="{$case/@name}" result="pass"/>
           else
               <test-case name="{$case/@name}" result="fail">
                   <exception>{$util:exception-message}</exception>
                   <query>{$query}</query>
               </test-case>
       )
   return $result
};

declare function xqts:finish() as empty() {
    let $result := doc("/db/XQTS/test-results/results.xml")/test-result
    let $passed := count($result//test-case[@result = 'pass'])
    let $failed := count($result//test-case[@result = 'fail'])
    return (
        update value $result/@passed with xs:int($passed),
        update value $result/@failed with xs:int($failed)
    )
};

declare function xqts:run-single-test-case($case as element(catalog:test-case),
    $group as element()?) as empty() {
    let $result := xqts:run-test-case($case)
    return
        if ($group) then
            update insert $result into $group
        else
            update insert $result into doc("/db/XQTS/test-results/results.xml")/test-result
};

declare function xqts:run-test-group($group as element(catalog:test-group),
    $parent as element()?) as empty() {
    update insert <test-group name="{$group/@name}">{$group/catalog:GroupInfo}</test-group>
        into $parent,
    let $newGroup := $parent/test-group[last()]
    return (
        for $test in $group/catalog:test-case
        let $log := util:log("DEBUG", ("Running test case: ", string($test/@name)))
        return
            xqts:run-single-test-case($test, $newGroup),
        for $childGroup in $group/catalog:test-group
        let $log := util:log("DEBUG", ("Entering group: ", string($childGroup/@name)))
        return
            xqts:run-test-group($childGroup, $newGroup)
    )
};

declare function xqts:test-single($name as xs:string) as empty() {
    let $test := //catalog:test-case[@name = $name]
    return
        xqts:run-single-test-case($test, collection("/db/XQTS/test-results")/test-result)
};

declare function xqts:test-group($groupName as xs:string) as empty() {
    let $group := //catalog:test-group[@name = $groupName]
    return
        xqts:run-test-group($group, collection("/db/XQTS/test-results")/test-result)
};

declare function xqts:test-all() as empty() {
    for $test in /catalog:test-suite/catalog:test-group
    return
        xqts:test-group($test/@name)
};

declare function xqts:get-input-value($input as element(catalog:input-file)) as item()* {
   if ($input eq "emptydoc") then
       ()
   else (
       let $source := root($input)//catalog:source[@ID = $input/text()]
       return
           if (empty($source)) then
               concat("no input found: ", $input/text())
           else
               doc(concat("/db/XQTS/", $source/@FileName))
   )
};

xqts:initialize(),
(: xqts:test-single("Axes001"), :)
xqts:test-group("MinimalConformance"),
(: xqts:test-all(), :)
xqts:finish(),
doc("/db/XQTS/test-results/results.xml")