XQuery Array implementation – implementing most of functions proposed in the XQuery 3.1 working draft and a few convenient functions.

array.xqm

(:~
 : Array Module
 : 
 : Implements Arrays in XQuery, according to the proposed
 : w3c working draft
 : http://www.w3.org/TR/xpath-functions-31/
 :
 : These arrays have the signature
 :   function(item()*, function(*)) as item()*
 : The Mogensen–Scott encoding is used to implement the data
 : type. The private typecheck ay:isarray#1 is as precise
 : as we can be, though it matches other functions with the 
 : same signature as well.
 :
 : Arrays containing an item $item can be constructed with
 :   ay:array($item, ay:empty())
 : which is equivalent to
 :   ay:singleton($item).
 : Arrays containing multiple items ($item_1, ..., $item_n) require
 : multiple nestings of ay:array#2 function like
 :   ay:array($item_1, ay:array($item_2, ay:array(..., ay:array($item_n, ay:empty()))))
 : 
 : A convenience function ay:ay($array) allows referencing an index $index of
 : an array $array like: ay:ay($array)($index).
 :
 : A function is usually followed by a unit test (using BaseX Unit Module).
 :
 : TODO implement ay:subarray
 : TODO add further tests
 : TODO refine ay:contains#2 (non-official function)
 :)
(: same namespace as in working draft :)
module namespace ay = "http://www.w3.org/2005/xpath-functions/array";

(: error namespace :)
declare %private variable $ay:err-ns := "http://www.w3.org/2005/xqt-errors";

(: errors in this module :)
declare %private %basex:lazy variable $ay:FOAY0001 := error(QName($ay:err-ns,'FOAY0001'), 'Array index out of bounds. An integer is used to select a member of an array outside the range of values for that array.');
declare %private %basex:lazy variable $ay:FOAY0002 := error(QName($ay:err-ns,'FOAY0002'), 'Negative array length. The $length argument to ay:subarray is negative.');

(:~
 : private array used for unit tests
 : tests two supplied arrays on their equality
 : requires BaseX Unit Module
 :)
declare %private variable $ay:fntest := function (
  $a as function(item()*, function(*)) as item()*,
  $b as function(item()*, function(*)) as item()*
) {
(: DEBUG   file:write('/tmp/' || random:uuid() || '.aytest.txt', ay:to-string($a)), :)
  unit:assert(ay:equal($a, $b))
};


(:
 : the type of any constructed map here is
 :   function(item()*, function(*)) as item()*
 :)

(: CONSTRUCTORS :)

(:~
 : Creates a new array from $tail sequence and head element.
 : @param $head head element
 : @param $tail tail array
 : @return non-empty array
 :)
declare function ay:array(
  $head as item()*,
  $tail as function(item()*, function(*)) as item()*
) as item()* {
  function(
    $array as function(item()*, function(*)) as item()*,
    $empty as function(*)
  ) as item()* {
    $array($head, $tail)
  }
};


(:~
 : Returns an empty array.
 : @return the empty array
 :)
declare function ay:empty(
) as function(function(item()*, function(*)) as item()*, function(*)) as item()* {
  function(
    $array as function(item()*, function(*)) as item()*,
    $empty as function(*)
  ) as item()* {
    $empty()
  }
};


(: not in w3c draft :)
(:~
 : Creates an array from one item.
 : Convenience function.
 : @param $item head element
 : @return non-empty array
 :)
declare function ay:singleton(
  $item as item()*
) as function(item()*, function(*)) as item()* {
  ay:array($item, ay:empty())
};


(: not in w3c draft :)
(:~
 : Constructs an array from a supplied sequence.
 : @param $seq  supplied sequence
 : @return array where items are in same order as in $seq
 :)
declare function ay:from-seq(
  $seq as item()*
) as function(item()*, function(*)) as item()* {
  fn:fold-left($seq, ay:empty(), ay:append#2)
};



(: FUNCTIONS :)

(:~
 : Returns the first member of an array, that is $array(1).
 : @param $array
 : @return array member at first position
 :)
declare function ay:head(
  $array as function(item()*, function(*)) as item()*
) as item()* {
  $array(
    function(
      $h as item()*,
      $t as function(item()*, function(*)) as item()*
    ) as item()* {
      $h
    },
    function (){()}
  )
};

declare %unit:test function ay:test-head() {
  (: get head element of sequence :)
  unit:assert-equals(
    ay:head( ay:from-seq(("a", "b", "c", "d", 1, 2, 3, 4)) ),
    "a"
  )
};


(:~
 : Returns an array containing all members except the first from a supplied array.
 : @param $array
 : @return tail of supplied array
 :)
declare function ay:tail(
  $array as function(item()*, function(*)) as item()*
) as function(item()*, function(*)) as item()* {
  $array(
    function(
      $h as item()*,
      $t as function(item()*, function(*)) as item()*
    ) as function(item()*, function(*)) as item()* {
      $t
    },
    function (){()}
  )  
};

declare %unit:test function ay:test-tail() {
  (: get tail of sequence :)
  $ay:fntest(
    ay:tail( ay:from-seq(("a", "b", "c", "d", 1, 2, 3, 4)) ),
    ay:from-seq(("b", "c", "d", 1, 2, 3, 4))
  )
};


(:~
 : Returns the number of members in the supplied array.
 : @param $array  supplied array
 : @return number of members in the supplied array.
 :)
declare function ay:size(
  $array as function(item()*, function(*)) as item()*
) as xs:integer {
  $array(
    function(
      $h as item()*,
      $t as function(item()*, function(*)) as item()*
    ) as xs:integer {
      ay:size($t)+1
    },
    function () as xs:integer {0}
  )
};


(:~
 :  Gets the value at the specified position in the supplied array (counting from 1).
 : @param $array the array
 : @param $index the index position
 : @return the element at $index in array
 :)
declare function ay:get(
  $array as function(item()*, function(*)) as item()*,
  $index as xs:integer
) as item()* {
  $array(
    function(
      $head as item()*,
      $tail as function(item()*, function(*)) as item()*
    ) as item()* {
      if ($index < 1)
      then $ay:FOAY0001
      else if ($index = 1)
      then $head (: return element :)
      else ay:get($tail, $index - 1)
    },
    function(){
      if ($index > 0)
      then $ay:FOAY0001
      else ()
    }
  )
};



(:~
 : Creates from supplied array
 : a convenience function for ay:get#2
 : The following rules apply:
 :   ay:ay($array)(0) == $array
 :   ay:ay($array)(1) == ay:head($array)
 :   ...
 : 
 : @param $array
 : @return a function#1
 :)
declare function ay:ay(
  $array as function(item()*, function(*)) as item()*
) as item()* {
  function ($pos as xs:integer?) {
    if (empty($pos) or $pos < 1)
    then $array
    else ay:get($array, $pos)
  }
};


(: not in w3c draft :)
(:~
 : Checks if the given array contains a given item using 
 : string cast on array members
 : @param $array array to be searched
 : @param $x value to look for
 : @return empty-sequence() if the value is not contained in the array, otherwise the position of first occurence of $x in the array
 :)
declare function ay:contains(
  $array as function(item()*, function(*)) as item()*,
  $x as item()*
) as xs:integer? {
  $array(
    function(
      $h as item()*,
      $ay as function(item()*, function(*)) as item()*
    ) as xs:integer? {
      if (
        $x castable as xs:string
        and $h castable as xs:string
        and $h cast as xs:string = $x cast as xs:string
      ) (: requires some equality comparison to be defined on the array items :)
      then 1
      else
        let $cts := ay:contains($ay, $x)
        return if ($cts instance of xs:integer)
          then $cts + 1
          else ()
    },
    function() as xs:integer? {()}
  )
};



(:~
 : Adds one member at the end of an array, creating a new array.
 : @param $array
 : @param $appendage
 : @return array that contains $appendage in the end
 :)
declare function ay:append(
  $array as function(item()*, function(*)) as item()*,
  $appendage as item()*
) as function(item()*, function(*)) as item()* {
  $array(
    function (
      $h as item()*,
      $t as function(item()*, function(*)) as item()*
    ) as item()* {
      ay:array($h, ay:append($t, $appendage))
    },
    function () as function(item()*, function(*)) as item()* {
      ay:array($appendage, ay:empty())
    }
  )
};


(:~
 : Converts an array to a flat sequence
 : can not flatten multidimensional arrays
 : @param $array
 : @return sequence of array entries
 :)
declare function ay:seq(
  $array as function(item()*, function(*)) as item()*
) as item()* {
  $array(
    function (
      $h as item()*,
      $t as function(item()*, function(*)) as item()*
    ) as item()* {
      $h, ay:seq($t)
    },
    function(){
      ()
    }
  )
};




(:~
 : Constructs an array by removing the member of a supplied array at a specified position.
 : @param $array supplied array
 : @return array missing the item at $position
 :)
declare function ay:remove(
  $array as function(item()*, function(*)) as item()*,
  $position as xs:integer
) as function(item()*, function(*)) as item()* {
  $array(
    function (
      $h as item()*,
      $t as function(*)
    ) as function(item()*, function(*)) as item()* {
      if ($position < 1)
      then $ay:FOAY0001
      else if ($position = 1)
      then $t
      else ay:array($h, ay:remove($t, $position - 1))
    },
    function () as function(item()*, function(*)) as item()* {
      if ($position > 0)
       then $ay:FOAY0001
      else ay:empty()
    }
  )
};


(:~
 : Constructs an array by adding all the members of a second array at a specified position.
 : Setting $position to 1 delivers the same result as
 :   ay:concat($array2, $array1).
 : Setting $position to the value
 :   ay:size($array) + 1
 : delivers the same result as
 : ay:concat($array1, $array2).
 : 
 : @param $array1 first supplied array
 : @param $position position where to insert second array
 : @param $array2 second supplied array
 : @return array containing $array2 starting at $position
 :)
declare function ay:insert-all-before(
  $array1 as function(item()*, function(*)) as item()*,
  $position as xs:integer,
  $array2 as function(item()*, function(*)) as item()*
) as function(item()*, function(*)) as item()* {
  $array1(
    function (
      $h as item()*,
      $t as function(*)
    ) as function(item()*, function(*)) as item()* {
      if ($position < 1)
      then $ay:FOAY0001
      else if ($position = 1)
      then ay:concat($array2, $t)
      else ay:array($h, ay:insert-all-before($t, $position - 1, $array2))
    },
    function () as function(item()*, function(*)) as item()* {
      if ($position > 1)
       then $ay:FOAY0001
      else $array2
    }
  )
};


(:~
 : Constructs an array by adding all the members of a second array at a specified position.
 : The function returns an array of size
 : ay:size($array) + 1
 : containing all members from $array whose position is less
 : than $position, then a new member given by $member, and then
 : all members from $array whose position is greater than or 
 : equal to $position. Positions are counted from 1.
 : 
 : @param $array1 first supplied array
 : @param $position position where to insert second array
 : @param $item supplied item to insert
 : @return array containing the supplied $item at $position
 :)
declare function ay:insert-member-before(
  $array as function(item()*, function(*)) as item()*,
  $position as xs:integer,
  $item as item()*
) as function(item()*, function(*)) as item()* {
  $array(
    function (
      $h as item()*,
      $t as function(*)
    ) as function(item()*, function(*)) as item()* {
      if ($position < 1)
      then $ay:FOAY0001
      else if ($position = 1)
      then ay:array($item, $array)
      else ay:array($h, ay:insert-member-before($t, $position - 1, $item))
    },
    function () as function(item()*, function(*)) as item()* {
      if ($position > 1)
       then $ay:FOAY0001
      else ay:array($item, ay:empty())
    }
  )
};


(:~
 : Concatenates two arrays to create a single array.
 : @param $array1
 : @param $array2
 : @return new array concatenated
 :)
declare function ay:concat(
  $array1 as function(item()*, function(*)) as item()*,
  $array2 as function(item()*, function(*)) as item()*
) as function(item()*, function(*)) as item()* {
  $array1(
    function(
      $h as item()*,
      $t as function(item()*, function(*)) as item()*
    ) as function(item()*, function(*)) as item()* {
      ay:array($h, ay:concat($t, $array2))
    },
    function () as function(item()*, function(*)) as item()* {
      $array2
    }
  )
};


(:~
 : Returns an array containing all the members of a supplied array, but in reverse order.
 : @param $array  supplied array
 : @return
 :)
declare function ay:reverse(
  $array as function(item()*, function(*)) as item()*
) as function(item()*, function(*)) as item()* {
  $array(
    function (
      $h as item()*,
      $t as function(item()*, function(*)) as item()*
    ) as function(item()*, function(*)) as item()* {
      ay:append(ay:reverse($t), $h)
    },
    ay:empty#0
  )
};

declare %unit:test function ay:test-reverse() {
  (: reverse an array :)
  $ay:fntest(
    ay:reverse(ay:from-seq(("a", "b", "c", "d", 1, 2, 3, 4))),
    ay:from-seq(fn:reverse(("a", "b", "c", "d", 1, 2, 3, 4)))
  )
};



(:~
 : Returns an array containing those members of the $array for which $function returns true.
 : @param $array  supplied array
 : @param $function a function
 : @return supplied array filtered by $function
 :)
declare function ay:filter(
  $array as function(item()*, function(*)) as item()*,
  $function as function(item()*) as xs:boolean
) as function(item()*, function(*)) as item()* {
  $array(
    function (
      $h as item()*,
      $t as function(item()*, function(*)) as item()*
    ) as function(item()*, function(*)) as item()* {
      let $t-filtered := ay:filter($t, $function)
      return if ($function($h))
        then ay:array($h, $t-filtered)
        else $t-filtered
    },
    ay:empty#0
  )
};

declare %unit:test function ay:test-filter() {
  (: filter an array for its integers :)
  $ay:fntest(
    ay:filter(
      ay:from-seq(("a", "b", "c", "d", 1, 2, 3, 4)),
      function ($a) as xs:boolean {
        $a instance of xs:integer
      }
    ),
    ay:from-seq((1, 2, 3, 4))
  ),
  $ay:fntest(
    ay:filter(
      ay:from-seq(("the cat", "sat", "on the mat")),
      function($s){count(tokenize($s, " ")) gt 1}
    ),
    ay:from-seq(("the cat", "on the mat"))
  ),
  $ay:fntest(
    ay:filter(ay:from-seq(("A", "B", "", 0, 1)), boolean#1),
    ay:from-seq(("A", "B", 1))
  )
};




(:~
 : Compares two supplied arrays component-wise
 : components must be comparable
 : @param $array1
 : @param $array2
 : @return equality iff each position in $array1 equals same position in $array2
 :)
declare function ay:equal(
  $array1 as function(item()*, function(*)) as item()*,
  $array2 as function(item()*, function(*)) as item()*
) as xs:boolean {
  $array1(
    function (
      $h as item()*,
      $t as function(item()*, function(*)) as item()*
    ) as xs:boolean {
      let $t2 := ay:tail($array2)
      return if (ay:isempty($t2) and not(ay:isempty($t)))
        then fn:false() (: different sized arrays are not equal :)
        else
          let $h2 := ay:head($array2)
          return
            if (ay:isarray($h) and ay:isarray($h2))
            then ay:equal($h, $h2)
            else
              fn:deep-equal($h, $h2) (: given types have to have equality defined :)
              and ay:equal($t, $t2)
    },
    function () as xs:boolean {
      ay:isempty($array2)
    }
  )
};


(:~
 : Concatenates the contents of several arrays into a single array.

 : @param $arrays
 : @return one array containing joined arrays
 :)
declare function ay:join(
  $arrays as function(*)*
) as function(item()*, function(*)) as item()* {
  fn:fold-right($arrays, ay:empty(), ay:concat#2)
};

declare %unit:test function ay:test-join() {
  (: reverse an array :)
  $ay:fntest(
    ay:join((ay:from-seq(("a", "b", "c", "d")), ay:from-seq((1, 2, 3, 4)))),
    ay:from-seq(("a", "b", "c", "d", 1, 2, 3, 4))
  )
};

(: not in w3c draft :)
(:~
 : checks if a supplied array is empty
 : @param $array  the array to check for emptyness
 : @return true if array has no members, otherwise false
 :)
declare function ay:isempty(
  $array as function(item()*, function(*)) as item()*
) as xs:boolean {
  $array(
    function(
      $h as item()*,
      $t as function(item()*, function(*)) as item()*
    ) as item()* {
      fn:false()
    },
    fn:true#0
  )
};

declare %unit:test function ay:test-isempty() {
  (: test for emptyness :)
  unit:assert-equals(
    ay:isempty(ay:from-seq(("a", "b", "c", "d", 1, 2, 3, 4))),
    fn:false()
  ),
  unit:assert-equals(
    ay:isempty(ay:empty()),
    fn:true()
  )
};


(:~
 : Evaluates the supplied function cumulatively on successive values of the supplied array.
 : @param $array
 : @param $zero
 : @param $function
 : @return 
 :)
declare function ay:fold-right(
  $array as function(item()*, function(*)) as item()*,
  $zero as item()*,
  $function as function(item()*, item()*) as item()*
) as item()* {
  $array(
    function(
      $h as item()*,
      $t as function(item()*, function(item()*, function(*)) as item()*) as item()*
    ) as item()* {
      $function($h, ay:fold-right($t, $zero, $function))
    },
    function () as item()* {$zero}
  )
};

(:~
 : Evaluates the supplied function cumulatively on successive values of the supplied array.
 : @param $array
 : @param $zero
 : @param $function
 : @return 
 :)
declare function ay:fold-left(
  $array as function(item()*, function(*)) as item()*, 
  $zero as item()*,
  $function as function(item()*, item()*) as item()*
) as item()* {
  $array(
    function(
      $h as item()*,
      $t as function(item()*, function(*)) as item()*
    ) as item()* {
      ay:fold-left($t, $function($zero, $h), $function)
    },
    function () as item()* {$zero}
  )
};


(: not in w3c draft :)
(:~
 : type check for supplied argument
 : @param $probable-array
 : @return true if probably, false otherwise
 :)
declare function ay:isarray(
  $probable-array as item()*
) as xs:boolean {
  try {
    function (
      $array as function(item()*, function(*)) as item()*
    ) as xs:boolean {
      $probable-array instance of function(*)
      and fn:true()
    }($probable-array)
  } catch * {
    fn:false()
  }
  (: TODO remove
  $probable-array instance of function (*)
  and (
    let $x := inspect:function($h)/argument
    return (
      $x[1]/@type = "item()*" 
      and $x[2]/@type = "function(*)"
    )
  ) :)
};

(: not in w3c draft :)
(:~
 : visualize an array as a string sequence
 : @param $array
 : @return array representation as string 
 :)
declare function ay:to-string(
  $array as function(item()*, function(*)) as item()*
) as xs:string {
  fn:concat('array{',
    ay:fold-right(
      $array,
      (),
      function (
        $h as item()*,
        $rest as xs:string?
      ) as xs:string? {
        let $h-string := $h ! (
          if (. instance of xs:boolean)
          then if (.) then "true()" else "false()"
          else if (. instance of xs:decimal)
          then xs:string(.)
          else if (. castable as xs:string)
          then fn:concat('"', xs:string(.), '"')
          else if (. instance of map(*))
          then "map{*}"
          else if (ay:isarray(.))
          then ay:to-string(.)
          else "-not serializable-"
        )
        let $h-string :=
          if (count($h) > 1)
          then fn:concat('(', string-join($h-string, ', '), ')')
          else $h-string
        return if (empty($rest))
          then $h-string
          else fn:concat($h-string, ', ', $rest)
      }
    )
  , '}')
};


(:~
 : Returns an array whose size is the same as ay:size($array), in which each member is computed by applying $function to the corresponding member of $array.
 : @param $array
 : @return 
 :)
declare function ay:for-each-member(
  $array as function(item()*, function(*)) as item()*,
  $function as function(item()*) as item()*
)  as function(item()*, function(*)) as item()* {
  $array(
    function (
      $h as item()*,
      $t as function(item()*, function(*)) as item()*
    ) {
      ay:array($function($h), ay:for-each-member($t, $function))
    },
    ay:empty#0
  )
};

declare %unit:test function ay:test-for-each-member() {
  $ay:fntest(
    ay:for-each-member(ay:from-seq(("the cat", "sat", "on the mat")), tokenize(?, " ")),
    ay:array(
      ("the","cat"),
      ay:array("sat",
        ay:singleton(("on", "the", "mat"))
      )
    )
  )
};

(:~
 : Returns an array obtained by evaluating the supplied function
 : once for each pair of members at the same position
 : in the two supplied arrays.
 : 
 : @param $array1
 : @param $array2
 : @param $function returns something
 : @return an array that has size of the minimum
 :         length of the two supplied arrays
 :)
declare function ay:for-each-pair(
  $array1 as function(item()*, function(*)) as item()*,
  $array2 as function(item()*, function(*)) as item()*,
  $function as function(*)
) as function(item()*, function(*)) as item()* {
  $array1(
    function (
      $h as item()*,
      $t as function(item()*, function(*)) as item()*
    ) as function(item()*, function(*)) as item()* {
      if (ay:isempty($array2))
      then ay:empty()
      else ay:array(
        $function($h, ay:head($array2)),
        ay:for-each-pair($t, ay:tail($array2), $function)
      )
    },
    ay:empty#0
  )
};

declare %unit:test function ay:test-for-each-pair() {
  (: should return [[a, 1], [b, 2], [c, 3]] :)
  $ay:fntest(
    ay:for-each-pair(
      ay:from-seq(("a", "b", "c", "d")),
      ay:from-seq((1, 2, 3)),
      function($x, $y) {
        ay:array($x, ay:singleton($y))
      }
    ),
    ay:join((
      ay:from-seq(("a", 1)),
      ay:from-seq(("b", 2)),
      ay:from-seq(("c", 3))
    ) ! ay:singleton(.))
  ),
  $ay:fntest(
    let $A := ay:from-seq(("A", "B", "C", "D"))
    return ay:for-each-pair($A, ay:tail($A), concat#2),
    ay:from-seq(("AB", "BC", "CD"))
  )
};

First draft of array implementation.