## \file hipadaba_configuration_common.tcl
# \brief Commands for building the hdb tree from sics object properties and an instrument dictionary.
#
# hobj policy: data=false control=parent nxsave=false klass=parent
# subtree/group_path policy:  data=parent control=parent nxsave=parent klass=parent
# type=macro & klass=command -> kind=command
# type=macro & klass!=command -> kind=script
# kind=script must have access property (read_only, read_write) and dtype and dlen

source $cfPath(hipadaba)/instdict_specification.tcl
source $cfPath(hipadaba)/common_instrument_dictionary.tcl

InstallHdb 

# TODO only use add_node to add hpaths and nodes,
#   eg add_node / path beam_monitor_scan prop_list {data true ...}

# eventid=source/type, type={parameter feedback graphics} eg hdb_bmonscan/feedback
proc update_node {name eventid access} {
  global nodeindex
  upvar $name signal
  hset $nodeindex($eventid) $signal($eventid)
}

proc add_hpath {basePath path {priv spy} {dtype none} {dlen ""}} {


  set parent $basePath
  array set prop_arr [::utility::hlistplainprop $basePath]
  foreach child [split $path /] {
    if {[lsearch [hlist $parent] $child] == -1} {
      hmake $parent/$child $priv $dtype $dlen
      if {$basePath != "/"} {
        hsetprop $parent/$child data $prop_arr(data)
        hsetprop $parent/$child control $prop_arr(control)
        hsetprop $parent/$child nxsave $prop_arr(nxsave)
        hsetprop $parent/$child klass @none
        hsetprop $parent/$child type $prop_arr(type)
      }
    } 
    if {$parent == "/"} {
      set parent /$child
    } else {
      set parent $parent/$child
    }
  }
  return $parent
}

proc add_cmd_par {hpath sobj name} {
  hattach $hpath $sobj $name
  #array set property [attlist $sobj]
#  hsetprop $hpath/$name argtype $property(argtype)
  foreach {prop pval} [attlist $sobj] {
    hsetprop $hpath/$name $prop $pval
  }
  hsetprop $hpath/$name data false
#  if {[info exists property(values)]} {
#    hsetprop $hpath/$name values $property(values)
#  }
#  if {[info exists property(min)]} {
#    hsetprop $hpath/$name min $property(min)
#  }
#  if {[info exists property(max)]} {
#    hsetprop $hpath/$name max $property(max)
#  }
}

proc add_feedback {hpath sobj name} {
  hattach $hpath $sobj $name
  foreach {prop pval} [attlist $sobj] {
    hsetprop $hpath/$name $prop $pval
  }
  hsetprop $hpath/$name privilege READ_ONLY
}

# args is an optional set of properties as name/value pairs.
# need node kind 
proc add_node {basePath args} {
  global nodeindex
  array unset arg_array
  array set arg_array $args;
  
  if {[info exists arg_array(path)] && [info exists arg_array(prop_list)]} {
    add_hpath $basePath $arg_array(path)
    if {$basePath == "/"} {
      set node_path /$arg_array(path)
    } else {
      set node_path $basePath/$arg_array(path)
    }
  #  if {[info exists arg_array(prop_list)]} {
      foreach {prop pval} $arg_array(prop_list) {
        hsetprop $node_path $prop $pval
      }
  #  }
    return $node_path
  }

  if {![info exists arg_array(dlen)]} {
    set arg_array(dlen) ""
  }
  set gp_path [file dirname $arg_array(node)]
  set node_name [file tail $arg_array(node)]
  if {$gp_path != "."} {
    add_hpath $basePath $gp_path
    set basePath $basePath/$gp_path
    hsetprop $basePath type part
  }
  if {[lsearch [hlist $basePath] $node_name] == -1} {
  #TODO allow hdb nodes of type drivable countable environment
    switch $arg_array(kind) {
      command {
        # A command is a macro, node=macro name 
        set command $node_name
        set cmd_path [add_command $basePath $command]
        set node_path $cmd_path
        # The extra arguments for add_node are supplied by the command parameters
        # and command feedback procedures.
        if {[string length [info procs ${command}_parameters]] > 0} {
          ${command}_parameters add_node $cmd_path
        } else {
          $command -map param add_cmd_par $cmd_path 
        }
        if {[string length [info procs ${command}_feedback]] > 0} {
          add_hpath $cmd_path feedback
          hsetprop $cmd_path/feedback type part
          ${command}_feedback add_node $cmd_path/feedback
        } else {
          add_hpath $cmd_path feedback
          hsetprop $cmd_path/feedback type part
          $command -map feedback add_feedback $cmd_path/feedback 
        }
      }
      event {
        # An event is a data array, node= a node path 
        add_hpath $basePath $node_name $arg_array(priv) $arg_array(dtype) $arg_array(dlen)
        set node_path $basePath/$node_name
        set nodeindex($arg_array(eventid),$arg_array(node)) $node_path
      }
      hobj {
        hattach $basePath $node_name $arg_array(long_name)
        set node_path $basePath/$arg_array(long_name)
        hsetprop $node_path data    [getatt $node_name data]
        hsetprop $node_path control [getatt $node_name control]
        hsetprop $node_path nxsave  [getatt $node_name nxsave]
        hsetprop $node_path klass   [getatt $node_name klass]
        foreach child [hlist $node_path] {
          hsetprop $node_path/$child data    false
          hsetprop $node_path/$child control [getatt $node_name control]
          hsetprop $node_path/$child nxsave  false
          hsetprop $node_path/$child klass   [getatt $node_name klass]
        }
      }
      ilist {
        set node_path $basePath
        set ilist_proc $node_name
        $ilist_proc add_node $node_path
      }
      script {
        # A r/w pair of scripts, node = a node path
        set node_path $basePath/[getatt $node_name long_name]
        array set attribute [attlist $node_name]
        set data_type [getatt $node_name dtype]
        set data_length [getatt $node_name dlen]
         if {[getatt $node_name access] == "read_only"} {
           hmakescript $node_path $node_name hdbReadOnly $data_type $data_length
         } else {
           hmakescript $node_path $node_name $node_name $data_type $data_length
         }
         hsetprop $node_path sicsdev $node_name
         hsetprop $node_path nxalias $node_name
         hsetprop $node_path data true
         hsetprop $node_path control false
         hsetprop $node_path klass [getatt $node_name klass]
         hsetprop $node_path sdsinfo [getatt $node_name sdsinfo]
         hsetprop $node_path savecmd [getatt $node_name savecmd]
         if {[info exists attribute(units)]} { 
           hsetprop $node_path units $attribute(units)
         }
        #hmakescript $node_path $arg_array(rscript) $arg_array(wscript) $arg_array(dtype) $arg_array(dlen)
      }
    }
    if {[info exists arg_array(prop_list)]} {
      foreach {prop pval} $arg_array(prop_list) {
        hsetprop $node_path $prop $pval
      }
    }
    return $node_path
  }
}

# Add command
proc add_command {basePath command} {
  array unset cmd_atts
  array set cmd_atts [attlist $command]
  if 0 {
  if {[info exists cmd_atts(group)]} {
    add_hpath $basePath $cmd_atts(group)
    set basePath $basePath/$cmd_atts(group)
    hsetprop $basePath type part
  }
  }
  hcommand $basePath/$cmd_atts(long_name) $command
  set cmd_ns [namespace qualifiers $command]
  if {[llength [trace info variable ::${cmd_ns}::event]] == 0} {
    trace add variable ::${cmd_ns}::event write update_node
  }
  set cmd_path $basePath/$cmd_atts(long_name)
  hsetprop $cmd_path privilege $cmd_atts(privilege)
  hsetprop $cmd_path type $cmd_atts(kind)
  hsetprop $cmd_path data $cmd_atts(data)
  hsetprop $cmd_path control $cmd_atts(control)
  hsetprop $cmd_path klass $cmd_atts(klass)
  hsetprop $cmd_path nxsave $cmd_atts(nxsave)
  return $cmd_path
} 

# attlist <sicsobj> 
# return a list of name value pairs for the sicsobj attributes
proc attlist {sicsobj} {
  foreach att [tolower_sicslist $sicsobj] {
    lappend atts [split [string range $att 0 end-1] =]
  }
  return [join $atts] 
}

# List sics objects with the given sics type, klass and group
proc sobjlist {atype aklass} {
  global sobj_sicstype_list

  switch $atype {
    command,macro {
      return [intersection [tolower_sicslist type macro] [tolower_sicslist klass $aklass] [tolower_sicslist kind command]]
    }
    script,macro {
      return [intersection [tolower_sicslist type macro] [tolower_sicslist klass $aklass] [tolower_sicslist kind script]]
    }
    "@any" {
      foreach st $sobj_sicstype_list {
        lappend sobjects [tolower_sicslist type $st]
      }
      return [intersection [join $sobjects] [tolower_sicslist klass $aklass]]
    }
    default {
      return [intersection [tolower_sicslist type $atype] [tolower_sicslist klass $aklass]]
    }
  }
}

proc getsobjatt {sicsobj attribute} {
  string trim [lindex [join [split [tolower_sicslist $sicsobj $attribute] =]] 1]
}


# Add the given sics object (sobj) of sobjtype to the
# given hipadaba path hpath.
# hpath must exist.
proc sobjadd {hpath sobj args} {
  array unset sobjatt
  array set sobjatt [attlist $sobj]
  sicslist setatt $sobj id $sobj
  switch $sobjatt(type) {
    motor - configurablevirtualmotor {
      if {[info exists sobjatt(group)]} {
        set hpath [add_hpath $hpath $sobjatt(group)]
        hsetprop $hpath type part
      }
      if {[lsearch [hlist $hpath] $sobjatt(long_name)] == -1} {
#        hattach $hpath $sobj $sobjatt(long_name)
#        hsetprop $hpath/$sobjatt(long_name) units $sobjatt(units)
#        hsetprop $hpath/$sobjatt(long_name) long_name $sobjatt(long_name)
      set node_path [add_node $hpath node $sobj long_name $sobjatt(long_name) kind $sobjatt(kind)]
      hsetprop $node_path savecmd $sobjatt(savecmd)
      hsetprop $node_path sdsinfo $sobjatt(sdsinfo)
      hsetprop $node_path nxalias $sobjatt(nxalias)
      hsetprop $node_path mutable $sobjatt(mutable)
      } else {
        clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
      }
    }
    macro {
    # access attribute = ro,rw
      if {[info exists sobjatt(group)]} {
        set hpath [add_hpath $hpath $sobjatt(group)]
        hsetprop $hpath type part
      }
      if {[lsearch [hlist $hpath] $sobjatt(long_name)] != -1} {
        clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
      } else {
        add_node $hpath kind $sobjatt(kind) node $sobj priv $sobjatt(privilege) 
      }
    }
    sicsvariable {
      if {[info exists sobjatt(group)]} {
        set hpath [add_hpath $hpath $sobjatt(group)]
        hsetprop $hpath type part
      } 
      if {[lsearch [hlist $hpath] $sobjatt(long_name)] == -1} {
        set node_path [add_node $hpath node $sobj long_name $sobjatt(long_name) kind $sobjatt(kind)]
        hsetprop $node_path sicsdev $sobj
        hsetprop $node_path nxalias $sobj
        hsetprop $node_path savecmd $sobjatt(savecmd)
        hsetprop $node_path sdsinfo $sobjatt(sdsinfo)
        hsetprop $node_path mutable $sobjatt(mutable)
        hsetprop $node_path privilege $sobjatt(privilege)
      } else {
        clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
      } 
    }
    node {
    }
    singlecounter {
# TODO 
      todo_msg "$sobjatt(type) case, add $sobj to $hpath"
    }
    histmem {
# TODO 
      todo_msg "$sobjatt(type) case, add $sobj to $hpath"
      if {[info exists sobjatt(group)]} {
        set hpath [add_hpath $hpath $sobjatt(group)]
        hsetprop $hpath type part
      } 
      if {[lsearch [hlist $hpath] $sobjatt(long_name)] == -1} {
        set node_path [add_node $hpath node $sobj long_name $sobjatt(long_name) kind $sobjatt(kind)]
        hsetprop $node_path savecmd $sobjatt(savecmd)
        hsetprop $node_path sdsinfo $sobjatt(sdsinfo)
        hsetprop $node_path nxalias $sobjatt(nxalias)
        hsetprop $node_path mutable $sobjatt(mutable)
        hsetprop $node_path sicsdev $sobj
      } else {
        clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
      } 
    }
    nxscript {
# TODO 
      todo_msg "$sobjatt(type) case, add $sobj to $hpath"
    }
    sicsdata  {
# TODO 
      todo_msg "$sobjatt(type) case, add $sobj to $hpath"
    }
    scanobject {
# TODO 
      todo_msg "$sobjatt(type) case, add $sobj to $hpath"
    } 
  } 
}

# sobjtypeadd <hpath> <sobjtype>
# Traverses list of sics objects of given type and attaches the matching sics objects to the given hpath
# Hipadaba node properties are constructed from the sobj attribute list.
proc sobjtypeadd {hpath sobjtype given_klass} {
  foreach {sobj} [sobjlist $sobjtype $given_klass] {
    sobjadd $hpath $sobj
  }
}


## \brief Remove empty instrument dictionary nodes 
#
# \param instdict name of the instrument dictionary structure
#
# Nodes which have no child nodes and no associated sics objects for the
# current instrument are removed.
proc prune {instdict} {
  upvar $instdict dict
  array set dictarr $dict
  set candidates [array names dictarr]
  # While there are candidates for removal remove the childless ones
  # which have an empty sobj list
  while {[expr [llength $candidates]] > 0} {
    set new_candidates ""
    foreach name $candidates {
      array unset dictval 
      array set dictval $dictarr($name)
      if {[lsearch $dictval(property) nxvgroup] != -1} {
        # Link targets are not candidates for pruning
        continue
      }
      set sobjects ""
      if {[info exists dictval(sobj)]} {
        foreach {t k} $dictval(sobj) {
          lappend sobjects [sobjlist $t $k]
        }
      }
      if { [llength [join $sobjects]] == 0 } {
        if {[llength [array get dictarr $name/*]] == 0} {
          array unset dictarr $name
        } else {
          if {[lsearch $candidates $name/*] != -1} {
            lappend new_candidates $name
          }
        }
      }
    }
    set candidates $new_candidates
  }
  set dict [array get dictarr]
  return
}
# 
#TODO add data control nxsave nxtyp properties
##\brief Traverse the instrument dictionary and construct the hipadaba database.
#
# \param instDict name of the instrument dictionary structure
#
# This command prunes the dictionary before building it.
# \see prune
proc buildHDB {instDict} {
upvar #0 $instDict dictionary
prune dictionary
  foreach {n v} $dictionary {
    array unset varr
    array set varr $v
    array unset property_array
    array set property_array $varr(property)
    add_node / path $n prop_list $varr(property)
    if {[info exists varr(sobj)]} {
      foreach {sicstype sobj_klass} $varr(sobj) {
        sobjtypeadd /$n $sicstype $sobj_klass
      }
    }
  }
}

namespace eval ::hdb {
  proc set_save {hpath mode {top true}} {
    if {$hpath != "/"} {
      set hnode $hpath
    } else {
      foreach hp [hlist /] {
        ::hdb::set_save /$hp $mode
      }
      return
    }
    if {[::utility::hgetplainprop $hnode data] == "false"} {
      return
    }
    foreach hp [hlist $hnode] {
      set_save $hnode/$hp $mode false
    }
    if {$top == "true"} { 
      hsetprop $hnode nxsave $mode
      if {$mode == "true"} {
        set hp ""
        foreach ps [lrange [split [string trim $hnode /] /] 0 end-1] {
          set hp $hp/$ps
          hsetprop $hp nxsave true
        } 
      }
    } else {
      hsetprop $hnode nxsave $mode
    }
  }
}