Eskil

# debug.tcl
#
#    Helpers for debugging.
#
#

namespace eval ::_Debug {
    
}

#-----------------------------------------------------------------------------
# Tracing
#-----------------------------------------------------------------------------

proc ::_Debug::TRenter {cmd op} {
    set fr [info frame -2]
    set line X
    if {[dict exists $fr line]} {
        set line [dict get $fr line]
    }
    puts "Line $line Enter: '$cmd'"
}
proc ::_Debug::TRenterstep {cmd op} {
    set fr [info frame -2]
    set line X
    if {[dict exists $fr line]} {
        set line [dict get $fr line]
    }
    puts "Line $line  Enterstep: '$cmd'"
}
proc ::_Debug::TRleave {cmd code res op} {
    puts "Leave: '$res'"
}
proc ::_Debug::TRleavestep {cmd code res op} {
    puts "Leavestep: '$res'"
}

proc ::_Debug::TR {cmd {step 0}} {
    TRoff $cmd
    trace add execution $cmd enter ::_Debug::TRenter
    trace add execution $cmd leave ::_Debug::TRleave
    if {$step} {
        trace add execution $cmd enterstep ::_Debug::TRenterstep
        trace add execution $cmd leavestep ::_Debug::TRleavestep
    }
}

proc ::_Debug::TRoff {cmd} {
    trace remove execution $cmd enter ::_Debug::TRenter
    trace remove execution $cmd leave ::_Debug::TRleave
    trace remove execution $cmd enterstep ::_Debug::TRenterstep
    trace remove execution $cmd leavestep ::_Debug::TRleavestep
}

#-----------------------------------------------------------------------------
# GUI
#-----------------------------------------------------------------------------

proc debugMenu {mW} {
    $mW add cascade -label "Debug" -menu $mW.debug -underline 0
    menu $mW.debug

    if {$::tcl_platform(platform) eq "windows"} {
        $mW.debug add checkbutton -label "Console" -variable ::consoleState \
                -onvalue show -offvalue hide -command {console $::consoleState} \
                -underline 0
        $mW.debug add separator
    }

    $mW.debug add command -label "Edit" -command ::_Debug::ProcEditor \
            -underline 0
    #after 500 ::_Debug::DumpStuff
    #after 500 ::_Debug::ProcEditor
    return $mW.debug
}

#-----------------------------------------------------------------------------
# Procedure/method editor
#-----------------------------------------------------------------------------

# An item was selected. Show it and make it editable.
proc ::_Debug::ProcEditorSelected {} {
    variable allcmds


    set ::_Debug::ProcEditor(current) ""
    set ::_Debug::ProcEditor(parent) ""

    set ::_Debug::ProcEditor(proc) ""


    set ::_Debug::ProcEditor(args) ""









    $::_Debug::ProcEditor(bodyW) delete 1.0 end








    set tree $::_Debug::ProcEditor(treeW)
    set items [$tree selection]
    if {[llength $items] < 1} return
    set item [lindex $items 0]
    set d $allcmds($item)
    set type [dict get $d type]
    set parent [dict get $d parent]

    set name [dict get $d name]


    set ::_Debug::ProcEditor(current) $item
    set ::_Debug::ProcEditor(parent) $parent
    set ::_Debug::ProcEditor(proc) $name

    set ::_Debug::ProcEditor(args) ""
    $::_Debug::ProcEditor(bodyW) delete 1.0 end


    set traceState normal
    if {$type eq "proc"} {
        set arglist {}
        foreach i [info args $item] {
            if {[info default $item $i value]} {
                lappend arglist [list $i $value]
            } else {
                lappend arglist [list $i]
            }
        }
        set body [info body $item]

        set ::_Debug::ProcEditor(args) $arglist
        $::_Debug::ProcEditor(bodyW) insert end $body
    } elseif {$type eq "method"} {
        lassign [info class definition $parent $name] arglist body
        set traceState disabled
        set ::_Debug::ProcEditor(args) $arglist
        $::_Debug::ProcEditor(bodyW) insert end $body
    } else {
        set traceState disabled
    }
    foreach w $::_Debug::ProcEditor(traceWs) {
        $w configure -state $traceState
    }

}

# Redefine currently edited proc/method
proc ::_Debug::ProcEditorRedefine {} {
    variable allcmds
    set body [$::_Debug::ProcEditor(bodyW) get 1.0 end]
    set body [string trimright $body]

    set item $::_Debug::ProcEditor(current)
    set d $allcmds($item)
    set type [dict get $d type]
    set parent [dict get $d parent]
    set name [dict get $d name]

    if {$type eq "proc"} {
        uplevel \#0 [list proc $item \
                             $::_Debug::ProcEditor(args) $body]
    } elseif {$type eq "method"} {
        uplevel \#0 [list oo::define $parent method $name \
                             $::_Debug::ProcEditor(args) $body]
    }
}

# Tracing of commands
proc ::_Debug::ProcEditorTrace {level} {
    variable allcmds
    set item $::_Debug::ProcEditor(current)
    set d $allcmds($item)
    set type [dict get $d type]
    set parent [dict get $d parent]
    set name [dict get $d name]
    if {$type ni "proc method"} return

    # TODO: methods
    if {$type eq "proc"} {
        if {$level == 1} {
            TR $item
        } elseif {$level == 2} {
            TR $item 1
        } else {
            TRoff $item
        }
    }
}

# Disassemble of current
proc ::_Debug::ProcEditorDisas {} {
    variable allcmds
    set item $::_Debug::ProcEditor(current)
    set d $allcmds($item)
    set type [dict get $d type]
    set parent [dict get $d parent]
    set name [dict get $d name]
    if {$type ni "proc method"} return
    
    if {$type eq "proc"} {
        set da [tcl::unsupported::disassemble proc $item]
    } else {
        set da [tcl::unsupported::disassemble method $parent $name]
    }        

    set top .proceditor.disas
    destroy $top
    ttk::toplevel $top
    wm title $top "Proc Editor Disassemble"

    text $top.t -yscrollcommand "$top.sby set"
    ttk::scrollbar $top.sby -orient vertical -command "$top.t yview"

    grid $top.t $top.sby -padx 3 -pady 3 -sticky news

    grid columnconfigure $top 0 -weight 1
    grid rowconfigure    $top 0 -weight 1

    $top.t insert end $da
}


# Treeview filtering. React on keystroke

proc ::_Debug::ProcEditorFilter {aVal kVal} {


    set f $::_Debug::ProcEditor(filter)
    set fx $::_Debug::ProcEditor(filterx)
    # Do not react unless changed.
    if {$f eq $fx} {
        return
    }
    set tree $::_Debug::ProcEditor(treeW)

    # Recreate the tree.
    # This is easier since the treeview does not have an item hide attribute.
    set pat *$f*
    TreePopulate $tree $pat
    set ::_Debug::ProcEditor(filterx) $f
}

# Make sure the hierarchy for a leaf exist, creating if needed.
proc ::_Debug::TreeCreatePath {tree path} {
    if {[$tree exists $path]} return
    set d $::_Debug::allcmds($path)
    set parent [dict get $d parent]
    if {$path ni {"" ::}} {
        TreeCreatePath $tree $parent
    }
    set text [dict get $d name]
    if {$parent eq "::"} {
        set parent ""
    }
    
    $tree insert $parent end -id $path -text $text -open 1 \
            -values [list $parent]
}

# Populate the treeview with all known procs and methods
proc ::_Debug::TreePopulate {tree {filter *}} {
    $tree delete [$tree children {}]
    foreach cmd [lsort -dictionary [array names ::_Debug::allcmds]] {
        set d $::_Debug::allcmds($cmd)
        set type [dict get $d type]
        if {$type ni "proc method"} continue
        if { ! [string match -nocase $filter [dict get $d name]]} continue
        
        set path [dict get $d parent]

        if {$path ne ""} {
            TreeCreatePath $tree $path
        }
        $tree insert $path end -id $cmd \
                -text [dict get $d name] -values [list $path]
    }
}


# Main Proc Editor window

proc ::_Debug::ProcEditor {} {
    ::_Debug::CollectInfo

    set top .proceditor
    destroy $top
    ttk::toplevel $top -padx 3 -pady 3
    wm title $top "Proc Editor"

    ttk::frame $top.ftree
    set ::_Debug::ProcEditor(filter) ""
    set ::_Debug::ProcEditor(filterx) ""
    ttk::entry $top.ftree.ef -textvariable ::_Debug::ProcEditor(filter)
    bind $top.ftree.ef <KeyRelease> {::_Debug::ProcEditorFilter %A %K}
    set tree $top.ftree.tree
    set ::_Debug::ProcEditor(treeW) $tree
    ttk::treeview $tree -height 20 -selectmode browse -show "tree" \
            -yscrollcommand "$top.ftree.sby set"
    ttk::scrollbar $top.ftree.sby -orient vertical -command "$tree yview"
    $tree tag configure highlight -background pink
    $tree column "#0" -minwidth 50 -width 200
    pack $top.ftree.ef -side "top" -fill x -padx 3 -pady 3
    pack $top.ftree.sby -side right -fill y -pady 3 -padx {0 3}
    pack $tree -fill both -expand 1 -pady 3 -padx {3 0}
    TreePopulate $tree
    bind $tree <<TreeviewSelect>> ::_Debug::ProcEditorSelected

    ttk::label $top.l1a -text "Parent" -anchor w
    ttk::label $top.l1b -textvariable ::_Debug::ProcEditor(parent) -anchor w
    ttk::label $top.l2a -text "Proc/Method" -anchor w


    ttk::label $top.l2b -textvariable ::_Debug::ProcEditor(proc) -anchor w
    ttk::label $top.l3a -text "Args" -anchor w
    ttk::label $top.l3b -textvariable ::_Debug::ProcEditor(args) -anchor w

    set ::_Debug::ProcEditor(bodyW) [text $top.t -yscrollcommand "$top.sby set" \
                                            -width 90]
    ttk::scrollbar $top.sby -orient vertical -command "$top.t yview"

    ttk::frame  $top.fb
    ttk::button $top.b1 -text "Redefine" -command ::_Debug::ProcEditorRedefine
    ttk::button $top.b2 -text "Disas"    -command ::_Debug::ProcEditorDisas
    ttk::button $top.b3 -text "Trace"    -command "::_Debug::ProcEditorTrace 1"
    ttk::button $top.b4 -text "Tr Step"  -command "::_Debug::ProcEditorTrace 2"
    ttk::button $top.b5 -text "Tr Off"   -command "::_Debug::ProcEditorTrace 0"
    set ::_Debug::ProcEditor(traceWs) [list $top.b3 $top.b4 $top.b5]
    grid $top.b1 $top.b2 $top.b3 $top.b4 $top.b5 -in $top.fb
    grid columnconfigure $top.fb all -weight 1 -uniform a

    grid $top.ftree $top.l1a $top.l1b -        -padx 3 -pady 3 -sticky news
    grid ^          $top.l2a $top.l2b -        -padx 3 -pady 3 -sticky we
    grid ^          $top.l3a $top.l3b -        -padx 3 -pady 3 -sticky we
    grid ^          $top.t  -         $top.sby -padx 3 -pady 3 -sticky news
    grid ^          $top.fb -         -        -padx 3 -pady 3 -sticky we

    grid columnconfigure $top 2 -weight 1
    grid rowconfigure    $top $top.t -weight 1
}

#-----------------------------------------------------------------------------
# Procedure/method information collection
#-----------------------------------------------------------------------------
#
# There is nuances to namespace handling that needs awareness.
#
# "parent" operates on just existing namespaces and cannot be used on
# procedures. It returns a normalized name, with a slight gotcha that
# top namespace is "::", thus ending in colons. Thus this cannot be used
# directly for joining without care.
# % namespace parent ::eskil::rev
# ::eskil
# % namespace parent eskil::rev
# ::eskil
# % namespace parent ::eskil
# ::
# % namespace parent ::
#
# "qualifier" pairs with "tail"
# It just parses the string and does not need to make sense.
# Thus this can be used on qualified procedure names.
# % namespace qualifier ::eskil::rev
# ::eskil
# % namespace qualifier eskil::rev
# eskil
# % namespace qualifier ::eskil
#
# Ditto with "tail"
# % namespace tail ::eskil::rev
# rev
# % namespace tail ::eskil
# eskil
# % namespace tail ::
#
# "children", like "parent", operates on real namespace and normalizes.
# % namespace children ::eskil
# ::eskil::rev
# % namespace children ::eskil::
# ::eskil::rev
# % namespace children ""
# ::eskil ::zlib ::pkg ::oo ::tcl
#
# Conclusion:
# If a namespace is always kept with "::" at the end things are mostly easy.
# "parent" and "children" will work, as well as joining with $parent$tail.
# This cannot be used with "qualifiers", so extra care is needed there.
# The helpers below handles this.

# Parent namespace. Always ends with ::
proc ::_Debug::Qualifiers {ns} {
    set ns [string trimright $ns ":"]
    set q [namespace qualifiers $ns]
    if { ! [string match *:: $q]} {
        append q ::
    }
    return $q
}
# Parent namespace. Always ends with ::
proc ::_Debug::Parent {ns} {
    set p [namespace parent $ns]
    if { ! [string match *:: $p]} {
        append p ::
    }
    return $p
}

# allcmds structure:
# fullId for different things:
#   proc: Its qualified namespace path. Name = leaf
#   namespace: Its qualified namespace path ending in ::. Name = leaf::
#   class: Its qualified namespace path. Name = leaf
#   method: A list of class id + method. Name = method
# allcmds(fullId) = dict:
#   type = proc/namespace/class/method/import
#   parent = fullId of parent/class
#   name = leaf name
#   origin = for import

# Collect all info about procedures/method/whatever.
# This is work in progress...
proc ::_Debug::CollectInfo {} {
    variable allcmds
    array set allcmds {}

    # Only do this once
    if {[array size allcmds] > 0} return

    # Find all commands in all namespaces
    set todoNs [list ::]
    while {[llength $todoNs] != 0} {
        set nsId [lindex $todoNs 0]
        set todoNs [lrange $todoNs 1 end]


        if {$nsId eq "::_Debug::"} continue

        set tail [namespace tail [string trimright $nsId ":"]]
        dict set allcmds($nsId) type   namespace
        dict set allcmds($nsId) parent [Parent $nsId]
        dict set allcmds($nsId) name   ${tail}::

        foreach child [namespace children $nsId] {
            lappend todoNs ${child}::
        }
        array unset thisround
        array set thisround {}
        # First collect commands, since we want to override with detail later
        foreach cmd [info commands $nsId*] {
            dict set allcmds($cmd) type "cmd"
            dict set allcmds($cmd) parent [Qualifiers $cmd]
            dict set allcmds($cmd) name [namespace tail $cmd]
            set thisround($cmd) 1
        }
        # Which ones are procs?
        foreach cmd [info procs $nsId*] {
            dict set allcmds($cmd) type "proc"
            dict set allcmds($cmd) parent [Qualifiers $cmd]
            dict set allcmds($cmd) name [namespace tail $cmd]
            set thisround($cmd) 0
        }
        # Which ones are imports?
        if { ! [catch {namespace eval $nsId {namespace import}} imports]} {
            foreach cmd $imports  {
                dict set allcmds($nsId$cmd) type "import"
                dict set allcmds($nsId$cmd) origin \
                        [namespace origin $nsId$cmd]
                set thisround($nsId$cmd) 0
            }
        }

        # Look through and command that is not something identified
        foreach cmd [array names thisround] {
            if { ! $thisround($cmd)} continue

            # Is it an ensemble?
            if {[namespace ensemble exists $cmd]} {
                #puts "ENSEMBLE $cmd"
                dict set allcmds($cmd) type ensemble
                foreach {key val} [namespace ensemble configure $cmd] {
                    #lappend allcmds($cmd) $key $val
                    if {$key eq "-map"} {
                        #puts "$cmd $val"
                        dict lappend allcmds($cmd) maps {*}$val
                    }
                    # Recognise a snit class
                    if {$key eq "-unknown" && [string match ::snit::* $val]} {
                        #puts "SNIT? $cmd"
                        #lset allcmds($cmd) 0 snit
                    }
                }
                set thisround($cmd) 0
                continue
            }
        }
        # Namespace ensembles?


    }

    # Go through tcloo classes
    set todoObj [list ::oo::object]
    while {[llength $todoObj] != 0} {
        set obj [lindex $todoObj 0]
        set todoObj [lrange $todoObj 1 end]


        dict set allcmds($obj) type class
        dict set allcmds($obj) parent [Qualifiers $obj]
        dict set allcmds($obj) name   [namespace tail $obj]

        foreach child [info class subclasses $obj] {
            lappend todoObj $child
        }
        foreach m [info class methods $obj -private] {
            set id [list $obj $m]
            dict set allcmds($id) type method
            dict set allcmds($id) parent $obj
            dict set allcmds($id) name $m
        }

    }
}

# Debug of debug
proc ::_Debug::DumpStuff {} {
    try {
        ::_Debug::CollectInfo
    } on error {res i} {
        puts $res
        puts $i
        after 1000
    }

    # Proc
    parray ::_Debug::allcmds *updateColors*
    parray ::_Debug::allcmds *cleanupAndExit
    # Cmd
    parray ::_Debug::allcmds *ttk::paned
    parray ::_Debug::allcmds *llength
    # OO class
    parray ::_Debug::allcmds *Account*
    # Snit class
    parray ::_Debug::allcmds *eskilprint*
    #
    parray ::_Debug::allcmds *indexEntry*
    exit
}

#-----------------------------------------------------------------------------
# Test just to include an OO object in the code
#-----------------------------------------------------------------------------
catch {Account destroy}
oo::class create Account {

    method transfer {amount targetAccount} {
        my variable total
        my withdraw $amount
        $targetAccount deposit $amount
        set total
    }
    method dump {} {
        #HoHA
    }
    destructor {
        my variable total
        if {$total} {puts "remaining $total will be given to charity"}
    }
}