treeql84.tcl

Go to the documentation of this file.

/*  treeql.tcl*/
/*  A generic tree query language in snit*/
/* */
/*  Copyright 2004 Colin McCormack.*/
/*  You are permitted to use this code under the same license as tcl.*/
/* */
/*  20040930 Colin McCormack - initial release to tcllib*/
/* */
/*  RCS: @(#) $Id: treeql84.tcl,v 1.10 2007/06/23 03:39:34 andreas_kupries Exp $*/

package require Tcl 8.4
package require snit
package require struct::list
package require struct::

snit = ::type ::treeql {
    variable nodes  ;/*  set of all nodes*/
    variable tree   ;/*  tree over which nodes are defined*/
    variable query  ;/*  full query - ie: 'parent' of this treeql object*/

    /*  low level accessor to tree*/
    ret  treeObj () {
    return $tree
    }

    /*  apply the [$tree cmd {*}$args] form to each node*/
    /*  returns the list of results of application*/
    ret  apply (type cmd , type args) {
    set result {}
    foreach node $nodes {
        if {[catch {
        eval [list $tree] $cmd [list $node] $args
        } application]} {
        upvar ::errorInfo eo
        puts stderr "apply: $tree $cmd $node $args -> $application - $eo"
        } else {
        #puts stderr "Apply: $tree $cmd $node $args -> $application"
        foreach a $application {lappend result $a}
        }
    }

    return $result
    }

    /*  filter nodes by [$tree cmd {*}$args]*/
    /*  returns the list of results of application when application is non nil*/
    ret  filter (type cmd , type args) {
    set result {}
    foreach node $nodes {
        if {[catch {
        eval [list $tree] $cmd [list $node] $args
        } application]} {
        upvar ::errorInfo eo
        puts stderr "filter: $tree $cmd $node $args -> $application - $eo"
        } else {
        #puts stderr "Filter: $tree $cmd $node $args -> $application"
        if {$application != {}} {
            lappend result $application
        }
        }
    }
    return $result
    }

    /*  filter nodes by the predicate [$tree cmd {*}$args]*/
    /*  returns the list of results of application when application is true*/
    ret  bool (type cmd , type args) {

    #puts stderr "Bool: $tree $cmd - $args"
    #set result [::struct::list filter $nodes [list $tree $cmd {*}$args]]
    #puts stderr "Bool: $tree $cmd - $nodes - $args -> $result"
    #return $result

    # replaced by tcllib's list filter
    set result {}
    foreach node $nodes {
        if {[catch {
        eval [list $tree] $cmd [list $node] $args
        } application]} {
        upvar ::errorInfo eo
        puts stderr "filter: $tree $cmd $node $args -> $application - $eo"
        } else {
        #puts stderr "bool: $tree $cmd $node $args -> $application - [$tree dump $node]"
        if {$application} {
            lappend result $node
        }
        }
    }

    return $result
    }

    /*  applyself - map cmd on $self to each node, discarding null results*/
    ret  applyself (type cmd , type args) {

    set result {}
    foreach node $nodes {
        if {[catch {
        eval [list $query] $cmd [list $node] $args
        } application]} {
        upvar ::errorInfo eo
        puts stderr "applyself: $tree $cmd $node $args -> $application - $eo"
        } else {
        if {[llength $application]} {
            foreach a $application {lappend result $a}
        }
        }
    }

    return $result
    }

    /*  mapself - map cmd on $self to each node*/
    ret  mapself (type cmd , type args) {

    set result {}
    foreach node $nodes {
        if {[catch {
        eval [list $query] $cmd [list $node] $args
        } application]} {
        upvar ::errorInfo eo
        puts stderr "mapself: $tree $cmd $node $args -> $application - $eo"
        } else {
        #puts stderr "Mapself: $query $cmd $node $args -> $application"
        lappend result $application
        }
    }

    return $result
    }

    /*  shim to perform operation $op on attribute $attr of $node*/
    ret  do_attr (type node , type op , type attr) {
    set attrv [$tree get $node $attr]
    #puts stderr "$self do_attr node:'$node' op:'$op' attr:'$attr' attrv:'$attrv'"
    return [eval [linsert $op end $attrv]]
    }

    /*  filter nodes by predicate [string $op] over attribute $attr*/
    ret  stringP (type op , type attr , type args) {
    set n {}
    set map [$self mapself do_attr [linsert $op 0 string] $attr]
    foreach result $map node $nodes {
        #puts stderr "$self stringP $op $attr -> $result - $node"
        if {$result} {
        lappend n $node
        }
    }
    set nodes $n
    return $args
    }

    /*  filter nodes by negated predicate [string $op] over attribute $attr*/
    ret  stringNP (type op , type attr , type args) {
    set n {}
    set map [$self mapself do_attr [linsert $op 0 string] $attr]
    foreach result $map node $nodes {
        if {!$result} {
        lappend n $node
        }
    }
    set nodes $n
    return $args
    }

    /*  filter nodes by predicate [expr {*}$op] over attribute $attr*/
    ret  exprP (type op , type attr , type args) {
    set n {}
    set map [$self mapself do_attr [linsert $op 0 expr] $attr]
    foreach result $map node $nodes {
        if {$result} {
        lappend n $node
        }
    }
    set nodes $n
    return $args
    }

    /*  filter nodes by predicate ![expr {*}$op] over attribute $attr*/
    ret  exprNP (type op , type attr , type args) {
    set n {}
    set map [$self mapself do_attr [linsert $op 0 expr] $attr]
    foreach result $map node $nodes {
        if {!$result} {
        lappend n $node
        }
    }
    set nodes $n
    return $args
    }

    /*  shim to return string values of attributes matching $pattern of a given $node*/
    ret  do_get (type node , type pattern) {
    set result {}
    foreach key [$tree keys $node $pattern] {
        set result [concat $result [$tree get $node $key]]
    }
    return $result
    }

    /*  Returns list of attribute values of attributes matching $pattern -*/
    ret  get (type pattern) {
    set nodes [$self mapself do_get $pattern]
    return {}   ;# terminate query
    }

    /*  Returns list of attribute values of the current node, in an unspecified order.*/
    ret  attlist () {
    $self get *
    return {}   ;# terminate query
    }

    /*  Returns list of lists of attributes of each node*/
    ret  attrs (type glob) {
    set nodes [$self apply keys $glob]
    return {}   ;# terminate query
    }

    /*  shim to find node ancestors by repetitive [parent]*/
    /*  as tcllib tree lacks this*/
    ret  do_ancestors (type node) {
    set ancestors {}
    set rootname [$tree rootname]
    while {$node ne $rootname} {
        lappend ancestors $node
        set node [$tree parent $node]
    }
    lappend ancestors $rootname
    return $ancestors
    }

    /*  path from node to root*/
    ret  ancestors (type args) {
    set nodes [$self applyself do_ancestors]
    return $args
   }

    /*  shim to find $node rootpath by repetitive [parent]*/
    /*  as tcllib tree lacks this*/
    ret  do_rootpath (type node) {
    set ancestors {}
    set rootname [$tree rootname]
    while {$node ne $rootname} {
        lappend ancestors $node
        set node [$tree parent $node]
    }
    lappend ancestors $rootname
    return [::struct::list reverse $ancestors]
    }

    /*  path from root to node*/
    ret  rootpath (type args) {
    set nodes [$self applyself do_rootpath]
    return $args
    }

    /*  node parent*/
    ret  parent (type args) {
    set nodes [$self apply parent]
    return $args
    }

    /*  node children*/
    ret  children (type args) {
    set nodes [$self apply children]
    return $args
    }

    /*  previous sibling*/
    ret  left (type args) {
    set nodes [$self apply previous]
    return $args
    }

    /*  next sibling*/
    ret  right (type args) {
    set nodes [$self apply next]
    return $args
    }

    /*  shim to find left siblings of node, in order of occurrence*/
    ret  do_previous* (type node) {
    if {$node == [$tree rootname]} {
        set children $node
    } else {
        set children [$tree children [$tree parent $node]]
    }
    set index [expr {[lsearch $children $node] - 1}]
    return [lrange $children 0 $index]
    }

    /*  previous siblings in reverse order*/
    ret  prev (type args) {
    set nodes [::struct::list reverse [$self applyself do_previous*]]
    return $args
    }

    /*  previous siblings in tree order*/
    ret  esib (type args) {
    set nodes [$self applyself do_previous*]
    return $args
    }

    /*  shim to find next siblings in tree order*/
    ret  do_next* (type node) {
    if {$node == [$tree rootname]} {
        set children $node
    } else {
        set children [$tree children [$tree parent $node]]
    }
    set index [expr {[lsearch $children $node] + 1}]
    return [lrange $children $index end]
    }

    /*  next siblings in tree order*/
    ret  next (type args) {
    set nodes [$self applyself do_next*]
    return $args
    }

    /*  generates the tree root*/
    ret  root (type args) {
    set nodes [$tree rootname]
    return $args
    }

    /*  shim to calculate descendants*/
    ret  do_subtree (type node) {
    set nodeset $node
    set children [$tree children $node]
    foreach child $children {
        foreach d [$self do_subtree $child] {lappend nodeset $d}
    }
    #puts stderr "do_subtree $node -> $nodeset"
    return $nodeset
    }

    /*  generates proper-descendants of nodes*/
    ret  descendants (type args) {
    set desc {}
    set nodeset {}
    foreach node $nodes {
        foreach d [lrange [$self do_subtree $node] 1 end] {lappend nodeset $d}
    }
    set nodes $nodeset
    return $args
    }

    /*  generates all subtrees rooted at node*/
    ret  subtree (type args) {
    set nodeset {}
    foreach node $nodes {
        foreach d [$self do_subtree $node] {lappend nodeset $d}
    }
    set nodes $nodeset
    return $args
    }

    /*  generates all nodes in the tree*/
    ret  tree (type args) {
    set nodes [$self do_subtree [$tree rootname]]
    return $args
    }

    /*  generates all subtrees rooted at node*/
    /* method descendants {args} {*/
    /*  set nodes [$tree apply descendants]*/
    /*  return $args*/
    /* }*/

    /*  flattened next subtrees*/
    ret  forward (type args) {
    set nodes [$self applyself do_next*]    ;# next siblings
    $self descendants   ;# their proper descendants
    return $args
    }

    /*  synonym for [forward]*/
    ret  later (type args) {
    $self forward
    return $args
    }

    /*  flattened previous subtrees in tree order*/
    ret  earlier (type args) {
    set nodes [$self applyself do_previous*]    ;# all earlier siblings
    $self descendants   ;# their proper descendants
    return $args
    }

    /*  flattened previous subtrees in reverse tree order*/
    /*  FIXME - this isn't going to return things in the correct order*/
    ret  backward (type args) {
    set nodes [$self applyself do_previous*]    ;# all earlier siblings
    $self subtree   ;# their subtrees
    set nodes [::struct::list reverse $nodes]   ;# reverse order
    return $args
    }

    /*  Returns the node type of nodes*/
    ret  nodetype () {
    set nodes [$self apply get @type]
    return {}   ;# terminate query
    }

    /*  Reduce to nodes of @type $t*/
    ret  oftype (type t , type args) {
    return [eval [linsert $args 0 $self stringP [list equal -nocase $t] @type]]
    }

    /*  Reduce to nodes not of @type $t*/
    ret  nottype (type t , type args) {
    return [eval [linsert $args 0 $self stringNP [list equal -nocase $t] @type]]
    }

    /*  Reduce to nodes whose @type is one of $attrs*/
    /*  @type values are assumed to be simple strings*/
    ret  oftypes (type attrs , type args) {
    set n {}
    foreach result [$self mapself do_attr list @type] node $nodes {
        if {[lsearch $attrs $result] > -1} {
        #puts stderr "$self oftypes '$attrs' -> $result - $node"
        lappend n $node
        }
    }
    set nodes $n
    return $args
    }

    /*  Reduce to nodes with attribute $attr (can be a glob)*/
    ret  hasatt (type attr , type args) {
    set nodes [$self bool keyexists $attr]
    return $args
    }

    /*  Returns values of attribute attname*/
    ret  attval (type attname) {
    $self hasatt $attname   ;# only nodes with attribute
    set nodes [$self apply get $attname]    ;# get the attribute nodes
    return {}   ;# terminate query
    }

    /*  Reduce to nodes with attribute $attr of $value*/
    ret  withatt (type attr , type value , type args) {
    $self hasatt $attr  ;# only nodes with attribute
    return [eval [linsert $args 0 $self stringP [list equal -nocase $value] $attr]]
    }

    /*  Reduce to nodes with attribute $attr of $value*/
    ret  withatt! (type attr , type val , type args) {
    return [eval [linsert $args 0 $self stringP [list equal $val] $attr]]
    }

    /*  Reduce to nodes with attribute $attr value one of $vals*/
    ret  attof (type attr , type vals , type args) {

    set result {}
    foreach node $nodes {
        set x [string tolower [[$self treeObj] get $node $attr]]
        if {[lsearch $vals $x] != -1} {
        lappend result $node
        }
    }

    set nodes $result
    return $args
    }

    /*  Reduce to nodes whose attribute $attr string matches $match*/
    ret  attmatch (type attr , type match , type args) {
    $self stringP [linsert $match 0 match] $attr
    return $args
    }

    /*  Side Effect: set attribute $attr to $val*/
    ret  set (type attr , type val , type args) {
    $self apply set $attr $val
    return $args
    }

    /*  Side Effect: unset attribute $attr*/
    ret  unset (type attr , type args) {
    $self apply unset $attr
    return $args
    }

    /*  apply string operation $op to attribute $attr on each node*/
    ret  string (type op , type attr) {
    set nodes [$self mapself do_attr [linsert $op 0 string] $attr]
    return {}   ;# terminate query
    }

    /*  remove duplicate nodes, preserving order*/
    ret  unique (type args) {
    set all {}
    array set keys {}
    foreach node $nodes {
        if {![info exists keys($node)]} {
        set keys($node) 1
        lappend all $node
        }
    }
    set nodes $all
    return $args
    }

    /*  construct the set of nodes present in both $nodes and node set $and*/
    ret  and (type and , type args) {
    set nodes [::struct::set intersect $and $nodes]
    return $args
    }

    /*  return result of new query $query, preserving current node set*/
    ret  subquery (type args) {
    set org $nodes  ;# save current node set
    set new [uplevel 1 [linsert $args 0 $query query]]
    set nodes $org  ;# restore old node set

    return $new
    }

    /*  perform a subquery and and in the result*/
    ret  andq (type q , type args) {
    $self and [uplevel 1 [linsert $q 0 $self subquery]]
    return $args
    }

    /*  construct the set of nodes present in $nodes or node set $or*/
    ret  or (type or , type args) {
    set nodes [::struct::set union $nodes $or]
    $self unique
    return $args
    }

    /*  perform a subquery and or in the result*/
    ret  orq (type q , type args) {
    $self or [uplevel 1 [linsert $q 0 $self subquery]]
    return $args
    }

    /*  construct the set of nodes present in $nodes but not node set $not*/
    ret  not (type not , type args) {
    set nodes [::struct::set difference $nodes $not]
    return $args
    }

    /*  perform a subquery and return the set of nodes not in the result*/
    ret  notq (type q , type args) {
    $self not [uplevel 1 [linsert $q 0 $self subquery]]
    return $args
    }

    /*  select the first of the nodes*/
    ret  select (type args) {
    set nodes [lindex $nodes 0]
    return $args
    }

    /*  perform a subquery then replace the nodeset*/
    ret  transform (type q , type var , type body , type args) {
    upvar 1 $var iter
    set new {}
    foreach n [uplevel 1 [linsert $q 0 $self subquery]] {
        set iter $n
        switch -exact -- [catch {uplevel 1 $body} result] {
        0 {
            # ok
            lappend new $result
        }
        1 {
            # pass errors up
            return -code error $result
        }
        2 {
            # return
            set nodes $result
            return
        }
        3 {
            # break
            break
        }
        4 {
            # continue
            continue
        }
        }
    }

    set nodes $new

    return $args
    }

    /*  replace the nodeset*/
    ret  map (type var , type body , type args) {
    upvar 1 $var iter
    set new {}
    foreach n $nodes {
        set iter $n
        switch -exact -- [catch {uplevel 1 $body} result] {
        0 {
            # ok
            lappend new $result
        }
        1 {
            # pass errors up
            return -code error $result
        }
        2 {
            # return
            set nodes $result
            return
        }
        3 {
            # break
            break
        }
        4 {
            # continue
            continue
        }
        }
    }

    set nodes $new

    return $args
    }

    /*  perform a subquery $query then map $body over results*/
    ret  foreach (type q , type var , type body , type args) {
    upvar 1 $var iter
    foreach n [uplevel 1 [linsert $q 0 $self subquery]] {
        set iter $n
        uplevel 1 $body
    }
    return $args
    }

    /*  perform a query, then evaluate $body*/
    ret  with (type q , type body , type args) {
    # save current node set, implied reset
    set org $nodes; set nodes {}

    uplevel 1 [linsert $q 0 $self query]
    set result [uplevel 1 $body]

    # restore old node set
    set new $nodes; set nodes $org

    return $args
    }

    /*  map $body over $nodes*/
    ret  over (type var , type body , type args) {
    upvar 1 $var iter
    set result {}
    foreach n $nodes {
        set iter $n
        uplevel 1 $body
    }
    return $args
    }

    /*  perform the query*/
    ret  query (type args) {
    # iterate over the args, treating each as a method invocation
    while {$args != {}} {
        #puts stderr "query $self $args"
        set args [uplevel 1 [linsert $args 0 $query]]
        #puts stderr "-> $nodes"
    }

    return $nodes
    }

    /*  append the literal $val to node set*/
    ret  quote (type val , type args) {
    lappend nodes $val
    return $args
    }

    /*  replace the node set with the literal*/
    ret  replace (type val , type args) {
    set nodes $val
    return $args
    }

    /*  set nodeset to empty*/
    ret  reset (type args) {
    set nodes {}
    return $args
    }

    /*  delete all nodes in node set*/
    ret  delete (type args) {

    foreach node $nodes {
        $tree cut $node
    }

    set nodes {}
    return $args
    }

    /*  return the node set*/
    ret  result () {
    return $nodes
    }

    constructor {args} {
     query =  [from args -query ""]
    if {$query == ""} {
         query =  $self
    }

     nodes =  [from args -nodes {}]

     tree =  [from args -tree ""]

    uplevel 1 [linsert $args 0 $self query]
    }

    /*  Return result, and destroy this query*/
    /*  useful in constructing a sub-query*/
    ret  discard (type args) {
    return [K [$self result] [$self destroy]]
    }

    ret  K (type x , type y) {
    set x
    }
}