Make some functions private

Make some functions private

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)
};

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 %private 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 %private 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 %private 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
        ()
};

(:~
 : 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: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
};

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)
};

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
        ()
};

(:~
 : 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: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
};


[bugfix] Collections did not show if you were not logged in

svn path=/trunk/eXist/; revision=14056

xquery version "1.0";

import module namespace config="http://exist-db.org/mods/config" at "../config.xqm";
import module namespace json="http://www.json.org";
import module namespace request = "http://exist-db.org/xquery/request";
import module namespace security="http://exist-db.org/mods/security" at "security.xqm";
import module namespace session = "http://exist-db.org/xquery/session";
import module namespace sharing="http://exist-db.org/mods/sharing" at "sharing.xqm";
import module namespace util="http://exist-db.org/xquery/util";
import module namespace xmldb = "http://exist-db.org/xquery/xmldb";

declare namespace exist = "http://exist.sourceforge.net/NS/exist";
declare namespace group = "http://commons/sharing/group";
declare namespace col = "http://library/search/collections";

declare option exist:serialize "method=json media-type=text/javascript";

(:~
: Generates tree nodes for navigation of collections in
: the library search app. Uses the JSON serializer to get JSON output.
:
: Also generates a virtual collection root called 'Groups', this starts
: as /db/commons/groups and then any sub-collection under here
: is actually a link back to the shared collection (i.e. a collection in a users home folder)
: Group collection paths look like /db/commons/group/{uuid}/{collection-name}
: The {uuid} refers to an entry stored in /db/commons/group
: The {collection-name} is the real name of the collection from the original users folder
:
: The JSON output generated is suitable for use with dynatree
:
: @author Adam Retter <adam@existsolutions.com>
:)

(:~
: Outputs details about a collection as a tree-node
:
: @param title
:   Title of the tree node
: @param collection-path
:   Collection path that backs the tree node
: @param is-folder
:   Is this tree node a folder?
: @param $icon-path
:   Optional path to a custom icon
: @param $tooltip
:   Optional tooltip
: @param writeable
:   Is this tree node writeable - i.e. can folders/resources be added to it
: @param additional-classes
:   Optional additional CSS classes to apply
: @param has-lazy-children
:   Are there children for this node which can be lazily fetched?
: @param explicit-children
:   Any children that should be explicity displayed, ignored if has-lazy-children is true()
:
:)
declare function col:create-tree-node($title as xs:string, $collection-path as xs:string, $is-folder as xs:boolean, $icon-path as xs:string?, $tooltip as xs:string?, $writeable as xs:boolean, $additonal-classes as xs:string*, $has-lazy-children as xs:boolean, $explicit-children as element(node)*) as element(node) {
    <node>
        <title>{$title}</title>
        <key>{$collection-path}</key>
        <isFolder>{$is-folder}</isFolder>
        <writeable>{$writeable}</writeable>
        <addClass>{
            fn:string-join(
                (if($writeable) then 'writable' else 'readable', $additonal-classes),
                ' '
            )
        }</addClass>
        {
        if($icon-path)then
            <icon>{$icon-path}</icon>
        else(),
        if($tooltip)then
            <tooltip>{$tooltip}</tooltip>
        else()
        }
        <isLazy>{$has-lazy-children}</isLazy>
        {
            if(not($has-lazy-children) and not(empty($explicit-children)))then
                for $explicit-child in $explicit-children return
                    <children>{$explicit-child/child::node()}</children>
            else()
        }
    </node>
};

(:~
: Gets the root collection and any special collections directly under root
:
: @param root-collection-path
:   Path to the root collection in the database
:)
declare function col:get-root-collection($root-collection-path as xs:string) as element(node) {

    let $user := security:get-user-credential-from-session()[1] return

        if(security:can-read-collection($user, $root-collection-path)) then
            let $children := xmldb:get-child-collections($root-collection-path),
            $can-write := security:can-write-collection($user, $root-collection-path),

            (: home collection :)
            $home-json :=
                if(security:home-collection-exists($user))then
                    let $home-collection-path := security:get-home-collection-uri($user),
                    $has-home-children := not(empty(xmldb:get-child-collections($home-collection-path))) return
                        col:create-tree-node("Home", $home-collection-path, true(), "../skin/ltFld.user.gif" , "Home Folder", true(), "userHomeSubCollection", $has-home-children, ())
                else(),

            (: group collection :)
            $has-group-children := not(empty(sharing:get-users-groups(security:get-user-credential-from-session()[1]))),
            $group-json := col:create-tree-node("Groups", $config:groups-collection, true(), "../skin/ltFld.groups.gif", "Groups", false(), (), $has-group-children, ())

            return

                (: root collection, containing home and group collection as children :)
                col:create-tree-node(fn:replace($root-collection-path, ".*/", ""), $root-collection-path, true(), (), (), $can-write, (), false(), ($home-json, $group-json))
        else()
};

(:~
: Gets lazy child collections
:
: @param collection-path
:   The parent collection path
:)
declare function col:get-child-collections($collection-path as xs:string) as element(json:value){

    let $user := security:get-user-credential-from-session()[1] return
        if(security:can-read-collection($user, $collection-path)) then

            (:get children :)
            let $children := xmldb:get-child-collections($collection-path) return

                <json:value>
                {
                    for $child in $children
                    let $child-collection-path := fn:concat($collection-path, "/", $child) return

                        (: output the child :)
                        col:get-collection($child-collection-path)
                }
                </json:value>
        else()
};

(:~
: Gets a collection
:
: @param collection-path
:    The path of the collection to retrieve
:)
declare function col:get-collection($collection-path as xs:string) as element(json:value) {

    let $user := security:get-user-credential-from-session()[1] return

        (: perform some checks on a child:)
        if(security:can-read-collection($user, $collection-path))then
            let $name := fn:replace($collection-path, ".*/", ""),
            $can-write := security:can-write-collection($user, $collection-path),
            $has-children := not(empty(xmldb:get-child-collections($collection-path))),
            $shared-with-group-id := sharing:get-group-id($collection-path),
            $tooltip :=
                if($shared-with-group-id)then
                    fn:concat("Shared With: ", sharing:get-group($shared-with-group-id)/group:name/text())
                else()
            return
                (: output the collection :)
                <json:value>
                {
                    col:create-tree-node($name, $collection-path, true(), (), $tooltip, $can-write, (), $has-children, ())/child::node()
                }
                </json:value>
        else()
};

(:~
: Gets the virtual "Groups" root, i.e. returns all groups that are accessible to a user
:)
declare function col:get-groups-virtual-root() as element(json:value) {

    let $groups := sharing:get-users-groups(security:get-user-credential-from-session()[1]) return
        <json:value>
        {
            for $group in $groups return
                <json:value>
                {
                    col:create-tree-node($group/group:name, fn:concat($config:groups-collection, "/", $group/@id), true(), (), (), false(), (), true(), ())/child::node()
                }
                </json:value>
        }
        </json:value>
};

(:~
: Generates the collections for a group in the navigation tree
:
: $group-collection-path The virtual collection path of the group e.g. /db/mods/groups/{uuid}
:)
declare function col:get-group-virtual-child-collections($collection-path as xs:string) as element(json:value) {

    (: extract the group id from the virtual collection path :)
    let $group-id := fn:replace($collection-path, ".*/", "") return

        <json:value>{
            (: iterate through every users collection :)
            for $user-collection in xmldb:get-child-collections($config:users-collection)
            let $user-collection-path := fn:concat($config:users-collection, "/", $user-collection),
            $child-nodes := col:resolve-real-users-collection-for-group($group-id, $user-collection-path) return
                for $node in $child-nodes return
                    element json:value {

                        (: TODO - we need this at the moment because if there is only one output node then the json output gets broken :)
                        if(count($child-nodes) eq 1)then
                            attribute json:array { "true" }
                        else(),

                        $node/child::node()
                    }
        }</json:value>
};

(:~
: Resolves a real collection from a users home folder for a group
:
: @param group-id
:   The id of the group to retrieve the collection for
:
: @param user-collection-path
:   The path of the users home folder to scan for collections that belong to the group-id
:)
declare function col:resolve-real-users-collection-for-group($group-id as xs:string, $user-collection-path as xs:string) as node()*
{
    let $user := security:get-user-credential-from-session()[1],
    $system-group := sharing:get-group($group-id)/group:system/group:group return
        for $user-sub-collection in xmldb:get-child-collections($user-collection-path)
        let $user-sub-collection-path := fn:concat($user-collection-path, "/", $user-sub-collection) return
            (
                if(security:get-group($user-sub-collection-path) eq $system-group)then(
                    col:get-collection($user-sub-collection-path)
                )else(),
                    col:resolve-real-users-collection-for-group($group-id, $user-sub-collection-path)
            )
};

(:~
: Request routing
:
: If the http querystring parameter key exists then we retrieve tree nodes based on this
: key which is basically a real or virtual (for groups) collection path.
: If there is no key we deliver the tree root
:)
if(request:get-parameter("key",()))then
    let $collection-path := request:get-parameter("key",()) return
        if($collection-path eq $config:groups-collection) then
            (: start of groups collection - the groups collection is virtual and so receives special treatment :)
            col:get-groups-virtual-root()
        else if(fn:starts-with($collection-path, $config:groups-collection)) then
            (: children of virtual group collection :)
            col:get-group-virtual-child-collections($collection-path)
        else
            (: just a child collection :)
            col:get-child-collections($collection-path)
else
    (: no key, so its the root that we want :)
    col:get-root-collection($config:mods-root)

xquery version "1.0";

import module namespace config="http://exist-db.org/mods/config" at "../config.xqm";
import module namespace json="http://www.json.org";
import module namespace request = "http://exist-db.org/xquery/request";
import module namespace security="http://exist-db.org/mods/security" at "security.xqm";
import module namespace session = "http://exist-db.org/xquery/session";
import module namespace sharing="http://exist-db.org/mods/sharing" at "sharing.xqm";
import module namespace util="http://exist-db.org/xquery/util";
import module namespace xmldb = "http://exist-db.org/xquery/xmldb";

declare namespace exist = "http://exist.sourceforge.net/NS/exist";
declare namespace group = "http://commons/sharing/group";
declare namespace col = "http://library/search/collections";

declare option exist:serialize "method=json media-type=text/javascript";

(:~
: Generates tree nodes for navigation of collections in
: the library search app. Uses the JSON serializer to get JSON output.
:
: Also generates a virtual collection root called 'Groups', this starts
: as /db/commons/groups and then any sub-collection under here
: is actually a link back to the shared collection (i.e. a collection in a users home folder)
: Group collection paths look like /db/commons/group/{uuid}/{collection-name}
: The {uuid} refers to an entry stored in /db/commons/group
: The {collection-name} is the real name of the collection from the original users folder
:
: The JSON output generated is suitable for use with dynatree
:
: @author Adam Retter <adam@existsolutions.com>
:)

(:~
: Outputs details about a collection as a tree-node
:
: @param title
:   Title of the tree node
: @param collection-path
:   Collection path that backs the tree node
: @param is-folder
:   Is this tree node a folder?
: @param $icon-path
:   Optional path to a custom icon
: @param $tooltip
:   Optional tooltip
: @param writeable
:   Is this tree node writeable - i.e. can folders/resources be added to it
: @param additional-classes
:   Optional additional CSS classes to apply
: @param has-lazy-children
:   Are there children for this node which can be lazily fetched?
: @param explicit-children
:   Any children that should be explicity displayed, ignored if has-lazy-children is true()
:
:)
declare function col:create-tree-node($title as xs:string, $collection-path as xs:string, $is-folder as xs:boolean, $icon-path as xs:string?, $tooltip as xs:string?, $writeable as xs:boolean, $additonal-classes as xs:string*, $has-lazy-children as xs:boolean, $explicit-children as element(node)*) as element(node) {
    <node>
        <title>{$title}</title>
        <key>{$collection-path}</key>
        <isFolder>{$is-folder}</isFolder>
        <writeable>{$writeable}</writeable>
        <addClass>{
            fn:string-join(
                (if($writeable) then 'writable' else 'readable', $additonal-classes),
                ' '
            )
        }</addClass>
        {
        if($icon-path)then
            <icon>{$icon-path}</icon>
        else(),
        if($tooltip)then
            <tooltip>{$tooltip}</tooltip>
        else()
        }
        <isLazy>{$has-lazy-children}</isLazy>
        {
            if(not($has-lazy-children) and not(empty($explicit-children)))then
                for $explicit-child in $explicit-children return
                    <children>{$explicit-child/child::node()}</children>
            else()
        }
    </node>
};

(:~
: Gets the root collection and any special collections directly under root
:
: @param root-collection-path
:   Path to the root collection in the database
:)
declare function col:get-root-collection($root-collection-path as xs:string) as element(node) {

    let $user := security:get-user-credential-from-session()[1] return

        if(security:can-read-collection($user, $root-collection-path)) then
            let $children := xmldb:get-child-collections($root-collection-path),
            $can-write := security:can-write-collection($user, $root-collection-path),

            (: home collection :)
            $home-collection-path := security:get-home-collection-uri($user),
            $has-home-children := not(empty(xmldb:get-child-collections($home-collection-path))),
            $home-json := col:create-tree-node("Home", $home-collection-path, true(), "../skin/ltFld.user.gif" , "Home Folder", true(), "userHomeSubCollection", $has-home-children, ()),

            (: group collection :)
            $has-group-children := not(empty(sharing:get-users-groups(security:get-user-credential-from-session()[1]))),
            $group-json := col:create-tree-node("Groups", $config:groups-collection, true(), "../skin/ltFld.groups.gif", "Groups", false(), (), $has-group-children, ())

            return

                (: root collection, containing home and group collection as children :)
                col:create-tree-node(fn:replace($root-collection-path, ".*/", ""), $root-collection-path, true(), (), (), $can-write, (), false(), ($home-json, $group-json))
        else()
};

(:~
: Gets lazy child collections
:
: @param collection-path
:   The parent collection path
:)
declare function col:get-child-collections($collection-path as xs:string) as element(json:value){

    let $user := security:get-user-credential-from-session()[1] return
        if(security:can-read-collection($user, $collection-path)) then

            (:get children :)
            let $children := xmldb:get-child-collections($collection-path) return

                <json:value>
                {
                    for $child in $children
                    let $child-collection-path := fn:concat($collection-path, "/", $child) return

                        (: output the child :)
                        col:get-collection($child-collection-path)
                }
                </json:value>
        else()
};

(:~
: Gets a collection
:
: @param collection-path
:    The path of the collection to retrieve
:)
declare function col:get-collection($collection-path as xs:string) as element(json:value) {

    let $user := security:get-user-credential-from-session()[1] return

        (: perform some checks on a child:)
        if(security:can-read-collection($user, $collection-path))then
            let $name := fn:replace($collection-path, ".*/", ""),
            $can-write := security:can-write-collection($user, $collection-path),
            $has-children := not(empty(xmldb:get-child-collections($collection-path))),
            $shared-with-group-id := sharing:get-group-id($collection-path),
            $tooltip :=
                if($shared-with-group-id)then
                    fn:concat("Shared With: ", sharing:get-group($shared-with-group-id)/group:name/text())
                else()
            return
                (: output the collection :)
                <json:value>
                {
                    col:create-tree-node($name, $collection-path, true(), (), $tooltip, $can-write, (), $has-children, ())/child::node()
                }
                </json:value>
        else()
};

(:~
: Gets the virtual "Groups" root, i.e. returns all groups that are accessible to a user
:)
declare function col:get-groups-virtual-root() as element(json:value) {

    let $groups := sharing:get-users-groups(security:get-user-credential-from-session()[1]) return
        <json:value>
        {
            for $group in $groups return
                <json:value>
                {
                    col:create-tree-node($group/group:name, fn:concat($config:groups-collection, "/", $group/@id), true(), (), (), false(), (), true(), ())/child::node()
                }
                </json:value>
        }
        </json:value>
};

(:~
: Generates the collections for a group in the navigation tree
:
: $group-collection-path The virtual collection path of the group e.g. /db/mods/groups/{uuid}
:)
declare function col:get-group-virtual-child-collections($collection-path as xs:string) as element(json:value) {

    (: extract the group id from the virtual collection path :)
    let $group-id := fn:replace($collection-path, ".*/", "") return

        <json:value>{
            (: iterate through every users collection :)
            for $user-collection in xmldb:get-child-collections($config:users-collection)
            let $user-collection-path := fn:concat($config:users-collection, "/", $user-collection),
            $child-nodes := col:resolve-real-users-collection-for-group($group-id, $user-collection-path) return
                for $node in $child-nodes return
                    element json:value {

                        (: TODO - we need this at the moment because if there is only one output node then the json output gets broken :)
                        if(count($child-nodes) eq 1)then
                            attribute json:array { "true" }
                        else(),

                        $node/child::node()
                    }
        }</json:value>
};

(:~
: Resolves a real collection from a users home folder for a group
:
: @param group-id
:   The id of the group to retrieve the collection for
:
: @param user-collection-path
:   The path of the users home folder to scan for collections that belong to the group-id
:)
declare function col:resolve-real-users-collection-for-group($group-id as xs:string, $user-collection-path as xs:string) as node()*
{
    let $user := security:get-user-credential-from-session()[1],
    $system-group := sharing:get-group($group-id)/group:system/group:group return
        for $user-sub-collection in xmldb:get-child-collections($user-collection-path)
        let $user-sub-collection-path := fn:concat($user-collection-path, "/", $user-sub-collection) return
            (
                if(security:get-group($user-sub-collection-path) eq $system-group)then(
                    col:get-collection($user-sub-collection-path)
                )else(),
                    col:resolve-real-users-collection-for-group($group-id, $user-sub-collection-path)
            )
};

(:~
: Request routing
:
: If the http querystring parameter key exists then we retrieve tree nodes based on this
: key which is basically a real or virtual (for groups) collection path.
: If there is no key we deliver the tree root
:)
if(request:get-parameter("key",()))then
    let $collection-path := request:get-parameter("key",()) return
        if($collection-path eq $config:groups-collection) then
            (: start of groups collection - the groups collection is virtual and so receives special treatment :)
            col:get-groups-virtual-root()
        else if(fn:starts-with($collection-path, $config:groups-collection)) then
            (: children of virtual group collection :)
            col:get-group-virtual-child-collections($collection-path)
        else
            (: just a child collection :)
            col:get-child-collections($collection-path)
else
    (: no key, so its the root that we want :)
    col:get-root-collection($config:mods-root)


go to centralized document management

go to centralized document management

(:~
: This is the Care Services Discovery stored query registry
: @version 1.1
: @see https://github.com/openhie/openinfoman
:
:)
module namespace fadpt = "https://github.com/openhie/openinfoman/adapter/fhir";

(:Import other namespaces.  Set default namespace  to os :)
import module namespace csd_webconf =  "https://github.com/openhie/openinfoman/csd_webconf";
import module namespace csr_proc = "https://github.com/openhie/openinfoman/csr_proc";
import module namespace csd_dm = "https://github.com/openhie/openinfoman/csd_dm";

declare namespace csd = "urn:ihe:iti:csd:2013";
declare namespace atom = "http://www.w3.org/2005/Atom";
declare namespace fhir = "http://hl7.org/fhir";

declare function fadpt:is_fhir_function($search_name) {
  let $function := csr_proc:get_function_definition($csd_webconf:db,$search_name)
  let $ext := $function//csd:extension[  @urn='urn:openhie.org:openinfoman:adapter' and @type='fhir']
  return (count($ext) > 0)
};

declare function fadpt:has_feed($search_name,$doc_name) {
  (fadpt:is_fhir_function($search_name) and csd_dm:document_source_exists($csd_webconf:db ,$doc_name))
};

declare function fadpt:get_base_url($search_name) {
  fadpt:get_base_url($search_name,$csd_webconf:baseurl)
};
declare function fadpt:get_base_url($search_name,$base_url) {
  concat($base_url,'CSD/adapter/fhir/' ,$search_name)
};

declare function fadpt:create_feed_from_entities($entities,$requestParams) {
  let $search_name := string($requestParams/@function)
  let $doc_name := string($requestParams/@resource)
  let $base_url := string($requestParams/@base_url)
  let $function := csr_proc:get_function_definition($csd_webconf:db,$search_name)
  let $entity := string(($function/csd:extension[ @urn='urn:openhie.org:openinfoman:adapter:fhir:read']/@type)[1])
  let $link := concat(fadpt:get_base_url($search_name,$base_url),'/' , $doc_name ,'/',$entity )
  let $title := concat("CSD entity as FHIR ",$entity)
  return
  <atom:feed>
    <atom:title>{$title}</atom:title>
    <atom:link href="{$link}" rel="self"/>
    <atom:updated>{current-dateTime()}</atom:updated>
     {
       for $entity in $entities
       let $ent_link := concat($link,"/", ($entity//fhir:identifier)[1])
       return
         <atom:entry>
	   <atom:link href="{$ent_link}"/>
	   <atom:content>{$entity}</atom:content>
	 </atom:entry>
     }
  </atom:feed>

};

(:
   Function to turn a CSD Facility entity into a FHIR Location
:)

declare function fadpt:represent_facility_as_location($doc,$facility)
{
  (: See http://www.hl7.org/implement/standards/fhir/location.html :)
  <fhir:Location >
    <fhir:identifier>{string($facility/@urn)}</fhir:identifier>
    <fhir:name>{($facility/csd:primaryName)[1]/text()}</fhir:name>
    {
      (
       (: Note: nothing readily apparent for description :)
       (:Note:  FHIR allows only one facility type:)
       for $type in  ($facility/csd:codedType)[1]
       return  <fhir:type><fhir:coding><fhir:system>{string($type/@codingScheme)}</fhir:system><fhir:code>{string($type/@code)}</fhir:code></fhir:coding></fhir:type>
       ,
       for $contact in  $facility/csd:contactPoint/csd:codedType
       return  <fhir:telecom>{$contact/text()}</fhir:telecom>
       ,
       (: Note: address is a bit weird.. which address? FHIR only allows for one. In CSD a provider
          can have a practice address as well as be assocaited to multiple facilities, each with their own address:)
       let $address :=  ($facility/csd:address[@type='Practice'])[1]
       return
	 if (exists($address))
	 then
	   <fhir:address>
	     {(
	       for $al in $address/csd:addressLine[@component = 'streetAddress']
	       return <fhir:line>{$al/text()}</fhir:line>
	       ,
	       for $city in ($address/csd:addressLine[@component = 'city'])[1]
	       return <fhir:city>{$city/text()}</fhir:city>
	       ,
	       for $state in ($address/csd:addressLine[@component = 'stateProvince'])[1]
	       return <fhir:state>{$state/text()}</fhir:state>
	       ,
	       for $zip in ($address/csd:addressLine[@component = 'postalCode'])[1]
	       return <fhir:zip>{$zip/text()}</fhir:zip>
	       ,
	       for $country in ($address/csd:addressLine[@component = 'country'])[1]
	       return <fhir:country>{$country /text()}</fhir:country>
	     )}
           </fhir:address>
	 else ()
	,
        (: Note: nothing immediate for Physical type :)
	if (exists($facility/csd:geocode)) then
	  <fhir:position>
	    <fhir:longitude>{$facility/csd:geocode/csd:longitude}</fhir:longitude>
	    <fhir:latitude>{$facility/csd:geocode/csd:latitude}</fhir:latitude>
	    <fhir:altitude>{$facility/csd:geocode/csd:altitude}</fhir:altitude>
	  </fhir:position>
	else ()
	,
	(:  Note: FHIR only permits one managinh organization but CSD has many :)
	for $org in ($facility/csd:organizations/csd:organization)[1]
	   (: Note: base for URL for reference should maybe be handled by stored function extension metadata   :)
	   return <fhir:managingOrganization><fhir:reference>Organization/{string($org/@urn)}</fhir:reference></fhir:managingOrganization>
	,
	(:May need to map codes :)
        <fhir:status>{string($facility/csd:record/@status)}</fhir:status>
	(:Note nothing immediately obvious for FHIR partOf or for FHIR mode :)
     )
    }

  </fhir:Location>
};

(:
   Function to turn a CSD Provider entity into a FHIR Practitioner
:)

declare function fadpt:represent_provider_as_practitioner($doc,$provider)
{
  (: See http://www.hl7.org/implement/standards/fhir/practitioner.html :)
  <fhir:Practitioner >
    <fhir:identifier>{string($provider/@urn)}</fhir:identifier>
    {
	let $name := ($provider/csd:demographic/csd:name)[1]
	let $cn := ($name/csd:commonName)[1]/text()
	let $sn := ($name/csd:surname)[1]/text()
	let $gn := ($name/csd:forename)[1]/text()
	let $hon := ($name/csd:honorific)[1]/text()
	return
	  <fhir:name>
	    <fhir:text value="{$cn}"/>
	    <fhir:family value="{$sn}"/>
	    <fhir:given value="{$gn}"/>
	    <fhir:prefix value="{$hon}"/>
	  </fhir:name>
    }
    {
      (
       for $contact in  $provider/csd:demographic/csd:contactPoint/csd:codedType
       return  <fhir:telecom>{$contact/text()}</fhir:telecom>
       ,
       (: Note: address is a bit weird.. which address? FHIR only allows for one. In CSD a provider
          can have a practice address as well as be assocaited to multiple facilities, each with their own address:)
       let $address :=  ($provider/csd:demographic/csd:address[@type='Practice'])[1]
       return
	 if (exists($address))
	 then
	   <fhir:address>
	     {(
	       for $al in $address/csd:addressLine[@component = 'streetAddress']
	       return <fhir:line>{$al/text()}</fhir:line>
	       ,
	       for $city in ($address/csd:addressLine[@component = 'city'])[1]
	       return <fhir:city>{$city/text()}</fhir:city>
	       ,
	       for $state in ($address/csd:addressLine[@component = 'stateProvince'])[1]
	       return <fhir:state>{$state/text()}</fhir:state>
	       ,
	       for $zip in ($address/csd:addressLine[@component = 'postalCode'])[1]
	       return <fhir:zip>{$zip/text()}</fhir:zip>
	       ,
	       for $country in ($address/csd:addressLine[@component = 'country'])[1]
	       return <fhir:country>{$country /text()}</fhir:country>
	     )}
           </fhir:address>
	 else ()
	,
	(: Note: what code set should we use in our output? :)
	let $gender := ($provider/csd:demographic/csd:gender)[1]
	return
	  if (exists($gender))  then  <fhir:gender>{$gender/text()}</fhir:gender>
	  else ()
	,
	let $dob := ($provider/csd:demographic/csd:dateOfBirth)[1]
	return
	  if (exists($dob))  then  <fhir:birthDate>{$dob/text()}</fhir:birthDate>
	  else ()
	,
	(:  Note: note supported under standard CSD   <photo><!-- 0..* Attachment Image of the person --></photo>  :)
	for $org in ($provider/csd:organizations/csd:organization)
	   (: Note: base for URL for reference should maybe be handled by stored function extension metadata   :)
	return <fhir:organization><fhir:reference>Organization/{string($org/@urn)}</fhir:reference></fhir:organization>
	,
	(: Note: perhaps this should be for services -- see remark below on <fhir:period/> :)
	for $role in ($provider/csd:codedType)
	return <fhir:role><fhir:coding><fhir:system>{string($role/@codingScheme)}</fhir:system><fhir:code>{string($role/@code)}</fhir:code></fhir:coding></fhir:role>
	,
	for $specialty in ($provider/csd:specialty)
	return <fhir:specialty><fhir:coding><fhir:system>{string($specialty/@codingScheme)}</fhir:system><fhir:code>{string($specialty/@code)}</fhir:code></fhir:coding></fhir:specialty>
	,
	(: Note: note supported <period><!-- 0..1 Period      The period during which the practitioner is authorized to perform in these role(s) § --></period>
           unless we interpret the <fhir:role/> element as a service
	:)
	for $fac in ($provider/csd:facilities/csd:facility)
	   (: Note: base for URL for reference should maybe be handled by stored function extension metadata   :)
	return <fhir:location><fhir:reference>Location/{string($fac/@urn)}</fhir:reference></fhir:location>
	,
	for $qual in ($provider/csd:credential)
	return
	  <fhir:qualification>
	    <fhir:code><fhir:coding><fhir:system>{string($qual/@codingScheme)}</fhir:system><fhir:code>{string($qual/@code)}</fhir:code></fhir:coding></fhir:code>
	    <fhir:period>
	       {if (exists($qual/csd:credenitalIssueDate)) then   <fhir:start>{$qual/csd:credenitalIssueDate}</fhir:start> else ()}
	       {if (exists($qual/csd:credentialRenewalDate)) then  <fhir:end>{$qual/csd:credentialRenewalDate}</fhir:end> else ()}
	    </fhir:period>
	    {
	      (:Note: I don't think this is quite correct.  It wants it to be an organization ID :)
	      if (exists($qual/csd:issuingAuthority)) then <fhir:issuer>{$qual/csd:issuingAuthority}</fhir:issuer> else ()
	    }
	  </fhir:qualification>
       ,
       for $lang in $provider/csd:language
       return  <fhir:communication><fhir:coding><fhir:system>{string($lang/@codingScheme)}</fhir:system><fhir:code>{string($lang/@code)}</fhir:code></fhir:coding></fhir:communication>
     )
    }

  </fhir:Practitioner>
};

(:~
: This is the Care Services Discovery stored query registry
: @version 1.1
: @see https://github.com/openhie/openinfoman
:
:)
module namespace fadpt = "https://github.com/openhie/openinfoman/adapter/fhir";

(:Import other namespaces.  Set default namespace  to os :)
import module namespace csd_webconf =  "https://github.com/openhie/openinfoman/csd_webconf";
import module namespace csr_proc = "https://github.com/openhie/openinfoman/csr_proc";
import module namespace csd_dm = "https://github.com/openhie/openinfoman/csd_dm";

declare namespace csd = "urn:ihe:iti:csd:2013";
declare namespace atom = "http://www.w3.org/2005/Atom";
declare namespace fhir = "http://hl7.org/fhir";

declare function fadpt:is_fhir_function($search_name) {
  let $function := csr_proc:get_function_definition($csd_webconf:db,$search_name)
  let $ext := $function//csd:extension[  @urn='urn:openhie.org:openinfoman:adapter' and @type='fhir']
  return (count($ext) > 0)
};

declare function fadpt:has_feed($search_name,$doc_name) {
  (fadpt:is_fhir_function($search_name) and csd_dm:is_registered($csd_webconf:db ,$doc_name))
};

declare function fadpt:get_base_url($search_name) {
  fadpt:get_base_url($search_name,$csd_webconf:baseurl)
};
declare function fadpt:get_base_url($search_name,$base_url) {
  concat($base_url,'CSD/adapter/fhir/' ,$search_name)
};

declare function fadpt:create_feed_from_entities($entities,$requestParams) {
  let $search_name := string($requestParams/@function)
  let $doc_name := string($requestParams/@resource)
  let $base_url := string($requestParams/@base_url)
  let $function := csr_proc:get_function_definition($csd_webconf:db,$search_name)
  let $entity := string(($function/csd:extension[ @urn='urn:openhie.org:openinfoman:adapter:fhir:read']/@type)[1])
  let $link := concat(fadpt:get_base_url($search_name,$base_url),'/' , $doc_name ,'/',$entity )
  let $title := concat("CSD entity as FHIR ",$entity)
  return
  <atom:feed>
    <atom:title>{$title}</atom:title>
    <atom:link href="{$link}" rel="self"/>
    <atom:updated>{current-dateTime()}</atom:updated>
     {
       for $entity in $entities
       let $ent_link := concat($link,"/", ($entity//fhir:identifier)[1])
       return
         <atom:entry>
	   <atom:link href="{$ent_link}"/>
	   <atom:content>{$entity}</atom:content>
	 </atom:entry>
     }
  </atom:feed>

};

(:
   Function to turn a CSD Facility entity into a FHIR Location
:)

declare function fadpt:represent_facility_as_location($doc,$facility)
{
  (: See http://www.hl7.org/implement/standards/fhir/location.html :)
  <fhir:Location >
    <fhir:identifier>{string($facility/@urn)}</fhir:identifier>
    <fhir:name>{($facility/csd:primaryName)[1]/text()}</fhir:name>
    {
      (
       (: Note: nothing readily apparent for description :)
       (:Note:  FHIR allows only one facility type:)
       for $type in  ($facility/csd:codedType)[1]
       return  <fhir:type><fhir:coding><fhir:system>{string($type/@codingScheme)}</fhir:system><fhir:code>{string($type/@code)}</fhir:code></fhir:coding></fhir:type>
       ,
       for $contact in  $facility/csd:contactPoint/csd:codedType
       return  <fhir:telecom>{$contact/text()}</fhir:telecom>
       ,
       (: Note: address is a bit weird.. which address? FHIR only allows for one. In CSD a provider
          can have a practice address as well as be assocaited to multiple facilities, each with their own address:)
       let $address :=  ($facility/csd:address[@type='Practice'])[1]
       return
	 if (exists($address))
	 then
	   <fhir:address>
	     {(
	       for $al in $address/csd:addressLine[@component = 'streetAddress']
	       return <fhir:line>{$al/text()}</fhir:line>
	       ,
	       for $city in ($address/csd:addressLine[@component = 'city'])[1]
	       return <fhir:city>{$city/text()}</fhir:city>
	       ,
	       for $state in ($address/csd:addressLine[@component = 'stateProvince'])[1]
	       return <fhir:state>{$state/text()}</fhir:state>
	       ,
	       for $zip in ($address/csd:addressLine[@component = 'postalCode'])[1]
	       return <fhir:zip>{$zip/text()}</fhir:zip>
	       ,
	       for $country in ($address/csd:addressLine[@component = 'country'])[1]
	       return <fhir:country>{$country /text()}</fhir:country>
	     )}
           </fhir:address>
	 else ()
	,
        (: Note: nothing immediate for Physical type :)
	if (exists($facility/csd:geocode)) then
	  <fhir:position>
	    <fhir:longitude>{$facility/csd:geocode/csd:longitude}</fhir:longitude>
	    <fhir:latitude>{$facility/csd:geocode/csd:latitude}</fhir:latitude>
	    <fhir:altitude>{$facility/csd:geocode/csd:altitude}</fhir:altitude>
	  </fhir:position>
	else ()
	,
	(:  Note: FHIR only permits one managinh organization but CSD has many :)
	for $org in ($facility/csd:organizations/csd:organization)[1]
	   (: Note: base for URL for reference should maybe be handled by stored function extension metadata   :)
	   return <fhir:managingOrganization><fhir:reference>Organization/{string($org/@urn)}</fhir:reference></fhir:managingOrganization>
	,
	(:May need to map codes :)
        <fhir:status>{string($facility/csd:record/@status)}</fhir:status>
	(:Note nothing immediately obvious for FHIR partOf or for FHIR mode :)
     )
    }

  </fhir:Location>
};

(:
   Function to turn a CSD Provider entity into a FHIR Practitioner
:)

declare function fadpt:represent_provider_as_practitioner($doc,$provider)
{
  (: See http://www.hl7.org/implement/standards/fhir/practitioner.html :)
  <fhir:Practitioner >
    <fhir:identifier>{string($provider/@urn)}</fhir:identifier>
    {
	let $name := ($provider/csd:demographic/csd:name)[1]
	let $cn := ($name/csd:commonName)[1]/text()
	let $sn := ($name/csd:surname)[1]/text()
	let $gn := ($name/csd:forename)[1]/text()
	let $hon := ($name/csd:honorific)[1]/text()
	return
	  <fhir:name>
	    <fhir:text value="{$cn}"/>
	    <fhir:family value="{$sn}"/>
	    <fhir:given value="{$gn}"/>
	    <fhir:prefix value="{$hon}"/>
	  </fhir:name>
    }
    {
      (
       for $contact in  $provider/csd:demographic/csd:contactPoint/csd:codedType
       return  <fhir:telecom>{$contact/text()}</fhir:telecom>
       ,
       (: Note: address is a bit weird.. which address? FHIR only allows for one. In CSD a provider
          can have a practice address as well as be assocaited to multiple facilities, each with their own address:)
       let $address :=  ($provider/csd:demographic/csd:address[@type='Practice'])[1]
       return
	 if (exists($address))
	 then
	   <fhir:address>
	     {(
	       for $al in $address/csd:addressLine[@component = 'streetAddress']
	       return <fhir:line>{$al/text()}</fhir:line>
	       ,
	       for $city in ($address/csd:addressLine[@component = 'city'])[1]
	       return <fhir:city>{$city/text()}</fhir:city>
	       ,
	       for $state in ($address/csd:addressLine[@component = 'stateProvince'])[1]
	       return <fhir:state>{$state/text()}</fhir:state>
	       ,
	       for $zip in ($address/csd:addressLine[@component = 'postalCode'])[1]
	       return <fhir:zip>{$zip/text()}</fhir:zip>
	       ,
	       for $country in ($address/csd:addressLine[@component = 'country'])[1]
	       return <fhir:country>{$country /text()}</fhir:country>
	     )}
           </fhir:address>
	 else ()
	,
	(: Note: what code set should we use in our output? :)
	let $gender := ($provider/csd:demographic/csd:gender)[1]
	return
	  if (exists($gender))  then  <fhir:gender>{$gender/text()}</fhir:gender>
	  else ()
	,
	let $dob := ($provider/csd:demographic/csd:dateOfBirth)[1]
	return
	  if (exists($dob))  then  <fhir:birthDate>{$dob/text()}</fhir:birthDate>
	  else ()
	,
	(:  Note: note supported under standard CSD   <photo><!-- 0..* Attachment Image of the person --></photo>  :)
	for $org in ($provider/csd:organizations/csd:organization)
	   (: Note: base for URL for reference should maybe be handled by stored function extension metadata   :)
	return <fhir:organization><fhir:reference>Organization/{string($org/@urn)}</fhir:reference></fhir:organization>
	,
	(: Note: perhaps this should be for services -- see remark below on <fhir:period/> :)
	for $role in ($provider/csd:codedType)
	return <fhir:role><fhir:coding><fhir:system>{string($role/@codingScheme)}</fhir:system><fhir:code>{string($role/@code)}</fhir:code></fhir:coding></fhir:role>
	,
	for $specialty in ($provider/csd:specialty)
	return <fhir:specialty><fhir:coding><fhir:system>{string($specialty/@codingScheme)}</fhir:system><fhir:code>{string($specialty/@code)}</fhir:code></fhir:coding></fhir:specialty>
	,
	(: Note: note supported <period><!-- 0..1 Period      The period during which the practitioner is authorized to perform in these role(s) § --></period>
           unless we interpret the <fhir:role/> element as a service
	:)
	for $fac in ($provider/csd:facilities/csd:facility)
	   (: Note: base for URL for reference should maybe be handled by stored function extension metadata   :)
	return <fhir:location><fhir:reference>Location/{string($fac/@urn)}</fhir:reference></fhir:location>
	,
	for $qual in ($provider/csd:credential)
	return
	  <fhir:qualification>
	    <fhir:code><fhir:coding><fhir:system>{string($qual/@codingScheme)}</fhir:system><fhir:code>{string($qual/@code)}</fhir:code></fhir:coding></fhir:code>
	    <fhir:period>
	       {if (exists($qual/csd:credenitalIssueDate)) then   <fhir:start>{$qual/csd:credenitalIssueDate}</fhir:start> else ()}
	       {if (exists($qual/csd:credentialRenewalDate)) then  <fhir:end>{$qual/csd:credentialRenewalDate}</fhir:end> else ()}
	    </fhir:period>
	    {
	      (:Note: I don't think this is quite correct.  It wants it to be an organization ID :)
	      if (exists($qual/csd:issuingAuthority)) then <fhir:issuer>{$qual/csd:issuingAuthority}</fhir:issuer> else ()
	    }
	  </fhir:qualification>
       ,
       for $lang in $provider/csd:language
       return  <fhir:communication><fhir:coding><fhir:system>{string($lang/@codingScheme)}</fhir:system><fhir:code>{string($lang/@code)}</fhir:code></fhir:coding></fhir:communication>
     )
    }

  </fhir:Practitioner>
};


forget to rename uuid variable in adapter interface

module namespace page = 'http://basex.org/modules/web-page';

import module namespace csr_proc = "https://github.com/openhie/openinfoman/csr_proc";
(:import module namespace csr_adpt = "https://github.com/openhie/openinfoman/csr_adpt"; :)
import module namespace csd_webconf =  "https://github.com/openhie/openinfoman/csd_webconf";
declare namespace csd = "urn:ihe:iti:csd:2013";

declare
  %rest:path("/CSD/adapter")
  %rest:GET
  %output:method("xhtml")
  function page:show_types()
{
  let $funcs := (csr_proc:stored_functions($csd_webconf:db), csr_proc:stored_updating_functions($csd_webconf:db))
  let $searches :=

      {
	for $adapter_func in $funcs[./csd:extension[@urn='urn:openhie.org:openinfoman:adapter']]
        let $desc := $adapter_func/csd:description
        let $types := $adapter_func/csd:extension[@urn='urn:openhie.org:openinfoman:adapter']/@type
	let $urn := string($adapter_func/@urn)
	return
	  for $type in $types
	  let $s_type := string($type)
	  return

	      Type ({$s_type})

	      Adapter Document Index (
	      {$urn}
			       )

	      Adapter Document Source (
	      {$urn}
			       )

{string($desc)}

      }

  return page:wrapper($searches)
};

declare
  %rest:path("/CSD/adapter/{$type}")
  %rest:GET
  %output:method("xhtml")
  function page:show_type($type)
{
  let $funcs := (csr_proc:stored_functions($csd_webconf:db), csr_proc:stored_updating_functions($csd_webconf:db))[./csd:extension[@type = $type] ]
  let $adaptations :=

{$type}

        {
	    for $adapter_func in $funcs
            let $desc := $adapter_func/csd:description
	    let $urn := string($adapter_func/@urn)
	    return

	      Type ({$type})

	      Adapter Document Index (
	      {$urn}
			       )

{$desc}

	}

  let $contents :=
    (
      Adapters
      ,$adaptations
      )
  return page:wrapper($contents)
};

declare function page:wrapper($response) {
  let $headers :=
  (<link rel="stylesheet" type="text/css" media="screen"   href="{$csd_webconf:baseurl}static/bootstrap-datetimepicker/css/bootstrap-datetimepicker.min.css"/>
  ,