[dbohdan] 2018-09-12: Classy YAO is a variation on [JCW]'s elegant [Yet another object system] ("YAO"). It takes the idea of YAO and adds classes, property validation, and ergonomic improvements like `self!` and an error on too many arguments. Like YAO's objects, its objects and classes are [transparent] values. (In this case, a "class" is a collection of methods and property names, default values, and restrictions on values. There is no inheritance or mixins.) It can check if a property of an object is assigned a correct value using `[string is]`, [enum%|%enums], or `[apply]` lambdas. ** Code ** Download with [wiki-reaper]: `wiki-reaper -x 55538 0 | tee cyao.tcl` ====== # Classy YAO, an object/record system for Tcl 8.5+ and Jim Tcl. # Copyright (c) 2018, 2020 D. Bohdan. # License: MIT. namespace eval ::cyao { variable version 0.4.0 variable jim [expr { [info exists ::tcl_platform(engine)] && $::tcl_platform(engine) eq {Jim} }] if {$jim} { alias ::! ::cyao::! alias ::!! ::cyao::!! alias ::self! ::cyao::self! } else { interp alias {} ::! {} ::cyao::! interp alias {} ::!! {} ::cyao::!! interp alias {} ::self! {} ::cyao::self! } } proc ::cyao::check-value-type {class field value} { if {![dict exists $class %TYPES% $field]} return set type [dict get $class %TYPES% $field] lassign $type typeName typeValues switch $typeName { any - string {} enum { if {$value ni $typeValues} { error [list value $value not in enum $typeValues] } } lambda { if {![apply $typeValues $value]} { error [list value $value fails validator $typeValues] } } default { if {![string is $type -strict $value]} { error [list value $value is not $type] } } } } proc ::cyao::! {classVarName selfVarName field args} { upvar $classVarName class upvar $selfVarName me if {![dict exists $class $field]} { error [list field $field not in class $classVarName] } set contents [dict get $class $field] switch [llength $contents] { 0 - 1 { if {[llength $args] == 0} { # Get the value only. if {[dict exists $me $field]} { set value [dict get $me $field] } else { set value $contents } check-value-type $class $field $value return $value } elseif {[llength $args] >= 2} { error {too many arguments} } # Set the value. set newValue [lindex $args 0] check-value-type $class $field $newValue dict set me $field $newValue return $newValue } 2 { # Evaluate the method. lassign $contents params body uplevel 1 [list \ apply \ [list \ $params \ "[list upvar $selfVarName me];\ [list upvar $classVarName class];\ $body" \ ] \ {*}$args \ ] } default { error [list field contents $contents has too many words] } } } proc ::cyao::define-class definiton { set class {} foreach {type field contents} $definiton { dict set class $field $contents if {$type ne {method}} { dict set class %TYPES% $field $type } } return $class } proc ::cyao::with-classes {mapping script} { upvar 1 %CLASSES% classes dict for {class varName} $mapping { dict set classes $varName $class } try { uplevel 1 $script } finally { dict for {class _} $mapping { dict unset classes $varName } } } proc ::cyao::!! {selfVarName field args} { upvar 1 %CLASSES% classes if {![info exists classes] || ![dict exists $classes $selfVarName]} { error [list do not know class of $selfVarName] } uplevel 1 [list ::cyao::! \ [dict get $classes $selfVarName] \ $selfVarName \ $field \ {*}$args] } proc ::cyao::self! {field args} { uplevel 1 [list ::cyao::! class me $field {*}$args] } namespace eval ::cyao::test { variable clsCounter { i 0 incr {{{n 1}} { self! i [expr { [self! i] + $n }] }} } variable clsCheckedCounter [::cyao::define-class { integer i 0 method set {n { self! i $n }} method incr {{{n 1}} { self! i [expr { [self! i] + $n }] }} }] variable clsCheckedList [::cyao::define-class { any label {} list data {} }] } proc ::cyao::test::benchmark {{max 10000} {times 5}} { if {[string match 8.5* [info patchlevel]]} { package require try } proc benchmark-dict max { set counter {i 0} # Not using [dict incr] here. for {set i 0} {$i < $max} {incr i} { dict set counter i [expr {[dict get $counter i] + 1}] } } proc benchmark-counter-field {class max} { variable $class set counter {} for {set i 0} {$i < $max} {incr i} { ! $class counter i [expr {[! $class counter i] + 1}] } } proc benchmark-counter-field-!! {class max} { variable $class set counter {} ::cyao::with-classes [list $class counter] { for {set i 0} {$i < $max} {incr i} { !! counter i [expr {[!! counter i] + 1}] } } } proc benchmark-counter-method {class max} { variable $class set counter {} for {set i 0} {$i < $max} {incr i} { ! $class counter incr } } proc benchmark-counter-method-!! {class max} { variable $class set counter {} ::cyao::with-classes [list $class counter] { for {set i 0} {$i < $max} {incr i} { !! counter incr } } } puts "Counting up to $max $times times." puts -nonewline { dict: } puts [time {benchmark-dict $max} 5] puts -nonewline { counter field: } puts [time {benchmark-counter-field clsCounter $max} $times] puts -nonewline { checked counter field: } puts [time {benchmark-counter-field clsCheckedCounter $max} $times] puts -nonewline { with-classes counter field: } puts [time {benchmark-counter-field-!! clsCounter $max} $times] puts -nonewline { with-classes checked counter field: } puts [time {benchmark-counter-field-!! clsCheckedCounter $max} $times] puts -nonewline { counter method: } puts [time {benchmark-counter-method clsCounter $max} $times] puts -nonewline { checked counter method: } puts [time {benchmark-counter-method clsCheckedCounter $max} $times] puts -nonewline { with-classes counter method: } puts [time {benchmark-counter-method-!! clsCounter $max} $times] puts -nonewline { with-classes checked counter method: } puts [time {benchmark-counter-method-!! clsCheckedCounter $max} $times] } proc ::cyao::test::test args { upvar constraints constraints upvar stats stats set name [lindex $args 0] lassign [lrange $args end-2 end] script arrow expected set args [lrange $args 1 end-3] foreach {option varName} {-setup setup -constraints myConstraints} { set $varName [expr { [dict exists $args $option] ? [dict get $args $option] : {} }] } dict incr stats total foreach constr $myConstraints { if {$constr ni $constraints} { dict incr stats skipped return } } eval $setup catch $script result set matched [switch -- $arrow { -> { expr {$result eq $expected} } ->* { string match $expected $result } ->$ { regexp -- $expected $result } default { return -code error \ -errorcode {JIMLIB TEST BAD-ARROW} \ [list unknown arrow: $arrow] } }] if {!$matched} { set error {} append error "\n>>>>> $name failed: [list $script]\n" append error " got: [list $result]\n" append error " expected: [list $expected]" if {$arrow ne {->}} { append error "\n match: $arrow" } puts stderr $error dict incr stats failed return } dict incr stats passed } proc ::cyao::test::run tests { if {[string match 8.5* [info patchlevel]]} { package require try } set constraints {} if {![set ::cyao::jim]} { lappend constraints !jim } set stats {total 0 passed 0 skipped 0 failed 0} set setup { variable clsCounter variable clsCheckedCounter set counter {} set result {} } set setupChecked { variable clsCheckedList set checkedList {} set result {} } test default-values-1.1 -setup $setup { ! clsCounter counter i } -> 0 test default-values-1.2 -setup $setup { dict set clsCounter i -157 lappend result [! clsCounter counter i] dict set clsCounter i 0 lappend result [! clsCounter counter i] } -> {-157 0} test methods-1.1 -setup $setup { lappend result [! clsCounter counter incr 1] lappend result [! clsCounter counter incr 98] dict set clsCounter i -157 lappend result [! clsCounter counter i] dict set clsCounter i 0 lappend result [! clsCounter counter i] lappend result $counter } -> {1 99 99 99 {i 99}} test object-copies-1.1 -setup $setup { set counter {i 99} lappend result [! clsCounter counter i] set counter2 $counter ! clsCounter counter2 incr lappend result [! clsCounter counter2 i] lappend result [! clsCounter counter i] } -> {99 100 99} test checked-values-1.1 -setup $setup { lappend result [! clsCheckedCounter counter i] lappend result [! clsCheckedCounter counter i 5] lappend result [! clsCheckedCounter counter incr] } -> {0 5 6} # Get wrong type. test checked-values-1.2 -setup $setup { set counter {i hello} ! clsCheckedCounter counter i } -> {value hello is not integer} # Sset wrong type. test checked-values-1.3 -setup $setup { set counter {i 5} ! clsCheckedCounter counter i 3.14159 } -> {value 3.14159 is not integer} test checked-values-2.1 -constraints !jim -setup $setupChecked { ! clsCheckedList checkedList data {1 2 3} ! clsCheckedList checkedList data } -> {1 2 3} test checked-values-2.2 -constraints !jim -setup $setupChecked { ! clsCheckedList checkedList data \{ } -> {value \{ is not list} test checked-values-2.3 -constraints !jim -setup $setupChecked { apply {{obj cls} { ! cls obj data {foo bar baz} }} $checkedList $clsCheckedList } -> {foo bar baz} test checked-values-2.4 -setup $setupChecked { ::cyao::with-classes {clsCheckedList checkedList} { !! checkedList label aribrary !! checkedList label } } -> aribrary test checked-values-3.0 -setup $setupChecked { set class [::cyao::define-class { {enum {RED GREEN BLUE UNKNOWN}} color UNKNOWN }] set object {color RED} catch { ! class object color MAROON } result set result [list $result] lappend result [! class object color] ! class object color BLUE lappend result [! class object color] } -> {{value MAROON not in enum {RED GREEN BLUE UNKNOWN}} RED BLUE} # Validators. test checked-values-4.0 -setup $setupChecked { set class [::cyao::define-class { {lambda {y {expr {$y >= 100}}}} x 100 }] set object {x 100} catch { ! class object x 95 } result set result [list $result] lappend result [! class object x] ! class object x 1000 lappend result [! class object x] } -> {{value 95 fails validator {y {expr {$y >= 100}}}} 100 1000} test with-classes-1.1 -setup $setup { ::cyao::with-classes {clsCounter counter} { lappend result [!! counter i] !! counter incr lappend result [!! counter i] !! counter i 108 lappend result [!! counter i] } } -> {0 1 108} puts $stats return [expr {[dict get $stats failed] == 0}] } proc ::cyao::test::main argv { set argv [lassign $argv verb] if {$verb eq {benchmark}} { benchmark {*}$argv } elseif {$verb eq {test}} { # Prevent tcltest from processing the command line. set ::argv {} if {![run $argv]} { exit 1 } } else { set file [file tail [info script]] puts stderr "usage: $file test \[test1 test2 ...\]" puts stderr " $file benchmark \[max \[times\]\]" if {$verb in {help -h -help --help /?}} { exit 0 } exit 1 } } # If this is the main script... if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} { cyao::test::main $argv } ====== ** Examples ** *** Property *** ====== % set foo {color {} size 0 type {}} % set obj1 {color red size 10 type apple} % ! foo obj1 color red % ! foo obj1 color #00ff33 #00ff33 % ! foo obj1 weather raining field weather not in class foo ====== *** Method *** ====== % set bar { factor 10 times {x { expr {$x * [self! factor] } }} } % set obj2 {} % ! bar obj2 factor 2 % list $obj2 {factor 2} % ! bar obj2 times 123 246 ====== *** Counter *** ====== % set TCounter { i 0 incr {{{n 1}} { self! i [expr { [self! i] + $n }] }} } % set counter {} % ! TCounter counter incr 1 % ! TCounter counter incr 2 % set copy $counter i 2 % ! TCounter counter incr 98 100 % ! TCounter copy incr 3 ====== *** Checked propery *** ====== % set class [cyao::define-class { {enum {green orange red}} color {} integer size 0 {enum {apple orange pear}} type {} }] % set obj1 {color red size 10 type apple} % ! class obj1 color red % ! class obj1 color blue value blue not in enum {green orange red} % set class2 [cyao::define-class { {lambda {t {expr {$t >= 0}}}} time 0 }] % set obj2 {time -3576} % ! class2 obj2 time value -3576 fails validator {t {expr {$t >= 0}}} ====== *** `!!` shortcut *** ====== % set TCounter { i 0 incr {{{n 1}} { self! i [expr { [self! i] + $n }] }} } % set counter {} % set %CLASSES% {counter TCounter copy TCounter} % !! counter incr 1 % !! counter incr 2 % set copy $counter i 2 % !! copy incr 3 ====== ** Benchmark results ** Because its objects are values and not namespaces, CYAO is much slower than [TclOO] or [snit]. Field access and method calls take approximately twice as long as in YAO. ======none > tclsh8.6 cyao.tcl benchmark Counting up to 10000 5 times. dict: 2606.2 microseconds per iteration counter field: 72646.2 microseconds per iteration checked counter field: 111957.8 microseconds per iteration with-classes counter field: 119191.6 microseconds per iteration with-classes checked counter field: 157488.0 microseconds per iteration counter method: 405813.0 microseconds per iteration checked counter method: 456929.6 microseconds per iteration with-classes counter method: 413484.0 microseconds per iteration with-classes checked counter method: 461076.8 microseconds per iteration > jimsh cyao.tcl benchmark Counting up to 10000 5 times. dict: 5847 microseconds per iteration counter field: 309817 microseconds per iteration checked counter field: 362382 microseconds per iteration with-classes counter field: 469050 microseconds per iteration with-classes checked counter field: 509477 microseconds per iteration counter method: 673991 microseconds per iteration checked counter method: 672644 microseconds per iteration with-classes counter method: 715829 microseconds per iteration with-classes checked counter method: 746731 microseconds per iteration ====== <> Jim Package | Object Orientation