[FM] Using TclOO to create "typed lists"

======
oo::class create typedlist {
    constructor {args} {
        my variable Liste
        my variable Type
        my variable counter -1
        if {[lindex $args 1] eq "-namespace"} {
            set namespace [lindex $args 2]
            uplevel [list namespace eval $namespace {}]
            set List [lindex $args 0]
        } else {
            set namespace []
            set Liste $args
        }
        set i [string last : [namespace tail [self]]]
        set Type [string range [namespace tail [self]] 0 $i-1]
        oo::objdefine [self] [subst {
            method unknown {args} {
                my variable counter
                typedlist create [list [self]]:\[incr counter\] {*}\$args
            }
        }]
    }
    method append {index args} {
        my variable Liste
        set e [lindex $Liste $index]
        lset Liste $index [append e {*}$args]
    }
    method get {} {
        my variable Liste
        return $Liste
    }
    method lappend {args} {
        my variable Liste
        lappend Liste {*}$args
    }
    method replace {debut fin args} {
        my variable Liste
        typedlist::nettoyer $Liste $debut $fin
        return [set Liste [lreplace $Liste $debut $fin {*}$args]]
    }
    method search {args} {
        my variable Liste
        set pattern [lindex $args end]
        return [lsearch {*}[lrange $args 0 end-1] $Liste $pattern]
    }
    method type {} {
        my variable Type
        return $Type
    }
    method transmute {type} {
        my variable Liste
        if {[info object class $type] eq "::typedlist"} {
            set new [$type -- {*}$Liste]
            after idle [list [self] destroy]
            return $new
        }
    }
    method -- {args} {
        my variable counter
        typedlist create [self]:[incr counter] {*}$args
    }

    export --

}
======
# Some additionals tools
======
namespace eval typedlist {}
======
# recreate a script from a typedlist 
======
proc ::typedlist::scriptifier {Typed} {
    set L []
    set T []
    if {[info object isa object $Typed] && [info object class $Typed] eq "::typedlist"} {
        foreach e [$Typed get] {
            append L \  [::typedlist::scriptifier $e]
        }
        append T [$Typed type] \  -- \ 
    } else {
        set L \{$Typed\}
        set T []
        return ${T}${L}
    }
    return \[$T$L\]
}

======
# test if the object is a typedlist
======
proc ::typedlist::is {T} {
    if {[info object isa object $T] \
            && [info object class $T] eq "::typedlist"} {
        return 1
    } else {
        return 0
    }
}
======
# equality test between two typedlist
======
proc ::typedlist::eq {L1 L2} {
    set res 0
    if {[::typedlist::is $L1] && [::typedlist::is $L2]} {
        if {[$L1 type] eq [$L2 type]} {
            foreach l1 [$L1 get] l2 [$L2 get] {
                set res [::typedlist::eq $l1 $l2]
            }
        }
    } elseif {![::typedlist::is $L1] && ![::typedlist::is $L2]} {
        if {$L1 eq $L2} {
            set res 1
        }
    }
    return $res
}
======
# clean-up tool
======
proc ::typedlist::nettoyer {Typed {debut {0}} {fin {end}}} {
    set L [list]
    if {[::typedlist::is $Typed]} {
        foreach e [lrange [$Typed get] $debut $fin] {
            ::typedlist::nettoyer $e
            if {[catch {$e destroy} err]} {
                puts stderr "erreur lors de la destruction de la liste $e, 
procédure : ::typedlist::nettoyer $Typed
message   : $err"
            }
        }
    } 
    return
}
package provide typedlist 0.2
======

What does it ? An object containing a type and a list.

Quick démo :
======
typedlist create rectangle
set A [rectangle -- 100 100 200 200]
$A get; # 100 100 200 200
$A type; # rectangle
$A lappend 300 100; # 100 100 200 200 300 100
typedlist create triangle
$A transmute ::triangle
$A type; # triangle
$A get; # 100 100 200 200 300 100
======

Applications :
    * [megawidget framework with tclOO (1)]
    * [parsing with coroutine]
    * [analogy between html markup and typedlist]
----

[PYK] 2014-11-06:  Made a small change to make sure a value in generated code
was properly encasulated in a list, and another small change to handle relative
namespaces better.

<<categories>> Category Object Orientation | Category Package