#
# This is a small debugger for Wafe. It is very experimental and
# has probably many bugs. it is quite dangerous to try to debug
# the debugger with itself. However, i found already a bug with it
# in a 6000 line Wafe application (tcl part), so other might like
# to share it.
#
# Essentialy, this debugger supports 
#   - call level tracing on 
#       + Tcl procedures,
#       + Wafe built-ins, and
#       + global Tcl variables (on read, write, unset)
#   - inspection of the current state of 
#       + Tcl procedures and
#       + global Tcl variables
#
# The debugger can be called by the Tcl Command "wafeDebug"
# and should be loaded via autoload. The current version uses
# the Athena widget set, it should be quite easy to provide
# OSF/Motif support as well
#
# Gustaf Neumann                         Mohegan Lake, May 5 1994

set wafeDebugDepth 0

set _wafeDebugIgnore(procs,wafeDebug) {}
set _wafeDebugIgnore(procs,wafeDebugLog) {}
set _wafeDebugIgnore(procs,wafeDebugShowStep) {}
set _wafeDebugIgnore(procs,pvars) {}
set _wafeDebugIgnore(procs,pset) {}
set _wafeDebugIgnore(procs,$) {}

# the "object" wafeDebug has
#   method create
#   method setSelection
#   method getSelection
#   method setMode
#   method getMode
#   method dismiss
#   method info
#   method reDraw
#   method trace
#   static instance variables: selection selectionList mode sh
proc wafeDebug { args } {
  # p is the name of the object class (equals procedure name)
  set self [lindex [info level 0] 0]

  static selection selectionList mode sh

  if [string match "" $args] {
    set method create
    set arguments {}
  } elseif [llength $args]==1 {
    set method $args
    set arguments {}
  } else {
    pset {method arguments} $args
  }

#  pvars method arguments

  switch $method {
    create {
      # if wafeDebug is called without arguments, 
      # it's widget structure is created if needed
      # and its shell is popped up
      if ![set sh [isWidget $self]] {
	# we have to create a new instance
	set sh [TopLevelShell $self topLevel title "Wafe Debugger"]
	if [window topLevel] {callback $sh popupCallback positionCursor 0}
	mergeResources topLevel \
	    *$self*left chainLeft \
	    *$self*Command.right chainLeft \
	    *$self*top chainTop \
	    *$self*bottom chainTop \
	    *$self*List*font -*-*-medium-r-*-*-12-*-*-*-*-*-*-* \
	    *$self*translations {#override
	        <Enter>: exec()
	        <Leave>: exec()
            } 
	set width 350
	set F [Form     form $sh ]
	set I [Label    info $F width $width label {} ]
        set V [Command  vars $F {
          callback "$self setMode %w" label "Global Variables"
          fromVert $I 
        }]
        set P [Command  procs $F {
          callback "$self setMode %w" label Procedures
          fromVert $I fromHoriz $V 
        }]
        set P [Command  commands $F {
          callback "$self setMode %w" label Built-Ins
          fromVert $I fromHoriz $P
        }]
        set VP [Viewport view $F {
          width $width height 250
          allowHoriz true allowVert true
          fromVert $V
          top chainTop bottom chainBottom right chainRight
        }]
        set L [List      list $VP {
          callback "$self setSelection %s" list {}
          width $width height 250
        }]
        set Q [Command quit $F {
          callback "$self dismiss" label "Dismiss"
          fromVert $VP
          top chainBottom bottom chainBottom
        }]
        set S [Command show $F {
          callback {
	    wafeDebugLog %w [wafeDebug getMode] [wafeDebug getSelection]
	  }
          label "Show" sensitive false
          fromVert $VP fromHoriz $Q
          top chainBottom bottom chainBottom
        }]
        set T [Command trace $F {
          callback {
	    wafeDebug %w [wafeDebug getMode] [wafeDebug getSelection]
	  }
          label "Trace" sensitive false
          fromVert $VP fromHoriz $S
          top chainBottom bottom chainBottom
        }]
        set GL [Label grepLabel $F {
          label "Grep:" borderWidth 0
          fromVert $VP fromHoriz $T
          top chainBottom bottom chainBottom
        }]
        set G [Text grep $F {
          editType Edit callback "$self reDraw"
          fromVert $VP fromHoriz $GL
          top chainBottom bottom chainBottom
        }]
        set selection {}
      }
      popup $sh none
      wafeDebugLog
    }

    getSelection {
      return $selection
    }

    getMode {
      return $mode
    }

    setSelection {
      sV $sh*show sensitive [string compare $mode commands]
      sV $sh*trace sensitive true
      set selection [string trimleft $arguments *\ ]
    }

    setMode {
      set mode $arguments
      global _wafeDebugIgnore
      switch $mode {
	commands {
	  set selectionList {}
	  foreach element [lsort [info commands]] {
	    if [catch {info args $element}] { 
	      if ![info exists _wafeDebugIgnore($mode,$element)] {
		lappend selectionList [wafeDebugListElement $mode $element]
	      } elseif [regexp {(.*)-orig} $element x oname] {
		lappend selectionList [wafeDebugListElement $mode $oname]
	      }
	    }
	  }
	}
	vars -
	procs {
	  set selectionList {}
	  foreach element [lsort [uplevel #0 "info $mode"]] {
	    if ![info exists _wafeDebugIgnore($mode,$element)] {
	      lappend selectionList [wafeDebugListElement $mode $element]
	    }
	  }
	}
      }
      $self reDraw
    }

    reDraw {
      set grepString [gV $sh*grep string]
      if [string compare "" $grepString] {
	set list ""
	foreach e $selectionList {
	  if [string match *$grepString* $e] { lappend list $e }
	}
	set theList list
      } else {
	set theList selectionList
      }
      XawListChange $sh*list 0 0 1 List [set $theList]
      set currentItem [lsearch -glob [set $theList] ?$selection]
      # pvars currentItem selection 
      if [string compare -1 $currentItem] {
	XawListHighlight $sh*list $currentItem
      }
    }

    info {
      sV $sh*info label [lindex $arguments 0]
    }

    trace {
      global _wafeDebugTrace _wafeDebugIgnore
      pset {type name} $arguments

      if [info exists _wafeDebugTrace($type,$name)] {
	unset _wafeDebugTrace($type,$name)
	switch $type {
	  vars {
	    uplevel #0 "trace vdelete $name w {wafeDebugLog traceVar}"
	    uplevel #0 "trace vdelete $name u {wafeDebugLog traceVar}"
	    uplevel #0 "trace vdelete $name r {wafeDebugLog traceVar}"
	  }
	  commands -
	  procs {
	    unset _wafeDebugIgnore($type,$name-orig)
	    rename $name ""
	    rename $name-orig $name
	  }
	}
	$self info "Removing Tracepoint for $name"
	$self setMode $type 
	return
      }
      switch $type {
	vars {
	  uplevel #0 "trace variable $name w {wafeDebugLog traceVar}"
	  uplevel #0 "trace variable $name u {wafeDebugLog traceVar}"
	  uplevel #0 "trace variable $name r {wafeDebugLog traceVar}"
	}
	commands -
	procs {
	  append new "proc $name args \{\n"
	  append new "  uplevel 1 wafeDebugShowStep $name $name-orig \[list \$args\]\n\}"
          catch {rename $name-orig ""}
          rename $name $name-orig
	  eval $new
	  set _wafeDebugIgnore($type,$name-orig) {}
	}
      }
      set _wafeDebugTrace($type,$name) {}
      $self info "Setting Trace Point for $name"
      $self setMode $type 
    }

    dismiss {
      popdown $sh
    }

  }
}

proc wafeDebugLog { args } {
  # the common prefix is the procedure name
  set self [lindex [info level 0] 0]

  static sh

  if [string match "" $args] {
    set method create
    set arguments {}
  } elseif [llength $args]==1 {
    set method $args
    set arguments {}
  } else {
    pset {method arguments} $args
  }
#  pvars method arguments

  switch $method {
    create {
      # if wafeDebugLog is called without arguments, 
      # it's widget structure is created if needed
      # and its shell is popped up

      if ![set sh [widgetId $self]] {
	# new instance
	set sh [TransientShell $self wafeDebug title "Wafe Debug Log" \
	    geometry -0+0]
	if [window topLevel] {callback $sh popupCallback positionCursor 0}
	mergeResources topLevel \
	    *$self*left chainLeft \
	    *$self*Command.right chainLeft \
	    *$self*top chainTop \
	    *$self*bottom chainTop \
	    *$self*Text*font -*-*-medium-r-*-*-12-*-*-*-*-*-*-* \
	    *$self*translations {#override
	        <Enter>: exec()
                <Leave>: exec()
            } 
        set width 530
        set F [Form  form $sh ]
	set I [Label info $F width $width label {}]
        set T [Text  text $F {
          editType edit type string string "" width $width height 300
          scrollVertical whenNeeded scrollHorizontal whenNeeded
          fromVert $I right chainRight bottom chainBottom
        }]
        Command quit $F {
	  callback "$self dismiss" label "Dismiss"
          fromVert $T
          top chainBottom bottom chainBottom
        }
      }
      if [string compare IsViewable [mapState $sh]] {
        sV $sh*text string ""
      }
      popup $sh none
    }

    displayText {
      if ![info exists sh] $self
      set w [widgetId $sh*text]
      callActionProc $w {} end-of-file
      set string [lindex $arguments 0]
      set cursorPosition [gV $w insertPosition]
      set text(firstPos) 0
      set text(length)   [set length [string length $string]]
      set text(ptr)      $string
      XawTextReplace $w $cursorPosition $cursorPosition text
      callActionProc $w {} end-of-file
#      sV $w insertPosition [incr cursorPosition $length]
    }

    traceVar {
      pset {name element op} $arguments
      pvars name element op
      global $name
      if [string match "" $element] {
	set var $name
      } else {
	set var "${name}($element)"
	upvar #0 $var n
      }
      switch $op {
	w {$self displayText "\n### $var = <$n>\n"}
	r {$self displayText "\n### $var == <$n> was read\n"}
	u {$self displayText "\n### $var was unset\n"}
      }
    }

    show {
      if ![info exists sh] $self
      pset {type name} $arguments
      switch $type {
	vars {
	  upvar #0 $name v
	  if [catch {array size v} error] {
	    $self displayText "\n### $name = <$v>\n"
	  } else {
	    $self displayText "\n### $name is an array\n"

	    #  parray v
	    # the following lines are from parray.tcl
	    set maxl 0
	    foreach n [lsort [array names v]] {
	      if {[string length $n] > $maxl} {
		set maxl [string length $n]
	      }
	    }
	    set maxl [expr {$maxl + [string length $name] + 2}]
	    foreach n [lsort [array names v]] {
	      set nameString [format %s(%s) $name $n]
	      $self displayText [format "%-*s = %s\n" $maxl $nameString $v($n)]
	    }
	  }
	}
	procs {
	  $self displayText "\n### The Definition of Procedure $name is:\n"
	  $self displayText [wafeDebugProcContents $name]
	}
      }
    }

    dismiss {
      popdown $sh
      sV $sh*text string {}
    }

  }
}


proc $ args {
  global wafeDebugDepth 
  set func [lindex $args 0]
  set backupDebugDepth $wafeDebugDepth 
  wafeDebugTraceLine call [incr wafeDebugDepth] "$args"
  if [catch {set result [uplevel 1 "eval $args"]} error] {
    wafeDebugTraceLine exit $wafeDebugDepth "$func aborted ($error)"
    set wafeDebugDepth $backupDebugDepth
    return -code error -errorinfo $error
  } else {
    wafeDebugTraceLine exit $wafeDebugDepth "$func returns <$result>"
    incr wafeDebugDepth -1
    return $result
  }
}

proc wafeDebugShowStep {func newFunc args} {
  global wafeDebugDepth 
  set backupDebugDepth $wafeDebugDepth 
  wafeDebugTraceLine call [incr wafeDebugDepth] "$func $args"
  if [catch {set result [uplevel 1 "eval $newFunc $args"]} error] {
    wafeDebugTraceLine exit $wafeDebugDepth "$func aborted ($error)"
    set wafeDebugDepth $backupDebugDepth
    return -code error -errorinfo $error
  } else {
    wafeDebugTraceLine exit $wafeDebugDepth "$func returns <$result>"
    incr wafeDebugDepth -1
    return $result
  }
}

proc wafeDebugTraceLine {port depth text} {
  wafeDebugLog displayText "#$port ($depth): $text\n"
}


proc wafeDebugListElement {mode element} {
  global _wafeDebugTrace
#  puts stderr "looking for ($mode,$element)"
  if [info exists _wafeDebugTrace($mode,$element)] {
    return *$element
  } else {
    return \ $element
  }
}

proc wafeDebugProcContents {procName} {
  if [uplevel #0 info exists _wafeDebugTrace(procs,$procName)] {
    set name $procName-orig
  } else {
    set name $procName
  }
  
  append proc {proc } $procName \ \{ [info args $name] \}\ \{
  append proc [info body $name] \} \n
  return $proc
}


# general routines, which should go into a different
# library once sufficiently debugged

proc pset {lvals rvals} {
  if {[llength $lvals] > [llength $rvals]} {
    error "pset argument list does not match value list ({$lvals}, {$rvals})"
  }
  set i 0
  foreach left $lvals {
    set val [lindex $rvals $i]
    uplevel 1 [list set $left $val]
    incr i
  }
  incr i -1
  uplevel 1 [list set $left [lrange $rvals $i end]]
}

proc static {args} {
  set procName [lindex [info level -1] 0]
  foreach varName $args {
    uplevel 1 "upvar #0 _staticvars($procName:$varName) $varName"
  }
}

proc pvars {args} {
  foreach varName $args {
    puts stderr [concat \
	[uplevel 1 {lindex [info level 0] 0}]:\ \
	[uplevel 1 "concat $varName = <$$varName>"]]
  }
}

#proc backtrace {} {
#  for {set l [info level]} { $l>0 } { incr l -1 } {
#    puts stderr "$l: [info level $l]"
#  }
#}


###### test procedures for tracing
#
#proc a {} {
#  set x 1
#  $ b $x 2
#  puts stderr "c returns [c $x]"
#  puts stderr "y=$y"
#}
#
#proc b {x y} {
#  return [expr $x+$y]
#}
#
#proc c {x} {
#  uplevel 1 set y 2
#  return [expr $x+$x]
#}
#

wafeDebug

