# git-gui simple class/object fake-alike
# Copyright (C) 2007 Shawn Pearce

proc class {class body} {
        if {[namespace exists $class]} {
                error "class $class already declared"
        }
        namespace eval $class "
                variable __nextid     0
                variable __sealed     0
                variable __field_list {}
                variable __field_array

                proc cb {name args} {
                        upvar this this
                        concat \[list ${class}::\$name \$this\] \$args
                }
        "
        namespace eval $class $body
}

proc field {name args} {
        set class [uplevel {namespace current}]
        variable ${class}::__sealed
        variable ${class}::__field_array

        switch [llength $args] {
        0 { set new [list $name] }
        1 { set new [list $name [lindex $args 0]] }
        default { error "wrong # args: field name value?" }
        }

        if {$__sealed} {
                error "class $class is sealed (cannot add new fields)"
        }

        if {[catch {set old $__field_array($name)}]} {
                variable ${class}::__field_list
                lappend __field_list $new
                set __field_array($name) 1
        } else {
                error "field $name already declared"
        }
}

proc constructor {name params body} {
        set class [uplevel {namespace current}]
        set ${class}::__sealed 1
        variable ${class}::__field_list
        set mbodyc {}

        append mbodyc {set this } $class
        append mbodyc {::__o[incr } $class {::__nextid]::__d} \;
        append mbodyc {create_this } $class \;
        append mbodyc {set __this [namespace qualifiers $this]} \;

        if {$__field_list ne {}} {
                append mbodyc {upvar #0}
                foreach n $__field_list {
                        set n [lindex $n 0]
                        append mbodyc { ${__this}::} $n { } $n
                        regsub -all @$n\\M $body "\${__this}::$n" body
                }
                append mbodyc \;
                foreach n $__field_list {
                        if {[llength $n] == 2} {
                                append mbodyc \
                                {set } [lindex $n 0] { } [list [lindex $n 1]] \;
                        }
                }
        }
        append mbodyc $body
        namespace eval $class [list proc $name $params $mbodyc]
}

proc method {name params body {deleted {}} {del_body {}}} {
        set class [uplevel {namespace current}]
        set ${class}::__sealed 1
        variable ${class}::__field_list
        set params [linsert $params 0 this]
        set mbodyc {}

        append mbodyc {set __this [namespace qualifiers $this]} \;

        switch $deleted {
        {} {}
        ifdeleted {
                append mbodyc {if {![namespace exists $__this]} }
                append mbodyc \{ $del_body \; return \} \;
        }
        default {
                error "wrong # args: method name args body (ifdeleted body)?"
        }
        }

        set decl {}
        foreach n $__field_list {
                set n [lindex $n 0]
                if {[regexp -- $n\\M $body]} {
                        if {   [regexp -all -- $n\\M $body] == 1
                                && [regexp -all -- \\\$$n\\M $body] == 1
                                && [regexp -all -- \\\$$n\\( $body] == 0} {
                                regsub -all \
                                        \\\$$n\\M $body \
                                        "\[set \${__this}::$n\]" body
                        } else {
                                append decl { ${__this}::} $n { } $n
                                regsub -all @$n\\M $body "\${__this}::$n" body
                        }
                }
        }
        if {$decl ne {}} {
                append mbodyc {upvar #0} $decl \;
        }
        append mbodyc $body
        namespace eval $class [list proc $name $params $mbodyc]
}

proc create_this {class} {
        upvar this this
        namespace eval [namespace qualifiers $this] [list proc \
                [namespace tail $this] \
                [list name args] \
                "eval \[list ${class}::\$name $this\] \$args" \
        ]
}

proc delete_this {{t {}}} {
        if {$t eq {}} {
                upvar this this
                set t $this
        }
        set t [namespace qualifiers $t]
        if {[namespace exists $t]} {namespace delete $t}
}

proc make_toplevel {t w args} {
        upvar $t top $w pfx this this

        if {[llength $args] % 2} {
                error "make_toplevel topvar winvar {options}"
        }
        set autodelete 1
        foreach {name value} $args {
                switch -exact -- $name {
                -autodelete {set autodelete $value}
                default     {error "unsupported option $name"}
                }
        }

        if {[winfo ismapped .]} {
                regsub -all {::} $this {__} w
                set top .$w
                set pfx $top
                toplevel $top
        } else {
                set top .
                set pfx {}
        }

        if {$autodelete} {
                wm protocol $top WM_DELETE_WINDOW "
                        [list delete_this $this]
                        [list destroy $top]
                "
        }
}


## auto_mkindex support for class/constructor/method
##
auto_mkindex_parser::command class {name body} {
        variable parser
        variable contextStack
        set contextStack [linsert $contextStack 0 $name]
        $parser eval [list _%@namespace eval $name] $body
        set contextStack [lrange $contextStack 1 end]
}
auto_mkindex_parser::command constructor {name args} {
        variable index
        variable scriptFile
        append index [list set auto_index([fullname $name])] \
                [format { [list source [file join $dir %s]]} \
                [file split $scriptFile]] "\n"
}