[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.
# Copyright (c) 2018, dbohdan.
# License: MIT.
package require Tcl 8.5
namespace eval cyao { variable version 0.3.12
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]} {
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 value.
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 value.
set newValue [lindex $args 0]
check-value-type $class $field $newValue
dict set me $field $newValue
return $newValue
}
2 {
# Evaluate method.
lassign $contents params body
set preamble [list upvar $selfVarName me]
append preamble \n[list upvar $classVarName class]
uplevel 1 [list apply [list $params $preamble\n$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 [namespace current]::! \
[dict get $classes $selfVarName] \
$selfVarName \
$field \
{*}$args]
}
proc cyao::self! {field args} {
uplevel 1 [list [namespace current]::! class me $field {*}$args]
}
namespace eval cyao::test {
namespace path [namespace parent]
variable clsCounter {
i 0
incr {{{n 1}} {
self! i [expr { [self! i] + $n }]
}}
}
variable clsCheckedCounter [define-class {
integer i 0
method set {n {
self! i $n
}}
method incr {{{n 1}} {
self! i [expr { [self! i] + $n }]
}}
}]
variable clsCheckedList [define-class {
any label {}
list data {}
}]
}
proc cyao::test::benchmark {{max 10000} {times 5}} {
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 {}
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 {}
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::run tests {
package require tcltest
package require try
namespace path [list [namespace parent] ::tcltest]
if {[llength $tests] > 0} {
tcltest::configure -match $tests
}
set counterSetupAndCleanup [list \
-setup {
variable clsCounter
variable clsCheckedCounter
set counter {}
set result {}
} \
-cleanup {
unset counter
unset result
} \
]
set checkedListSetupAndCleanup [list \
-setup {
variable clsCheckedList
set checkedList {}
set result {}
} \
-cleanup {
unset checkedList
unset result
} \
]
test default-values-1.1 {} {*}$counterSetupAndCleanup -body {
! clsCounter counter i
} -result 0
test default-values-1.2 {} {*}$counterSetupAndCleanup -body {
dict set clsCounter i -157
lappend result [! clsCounter counter i]
dict set clsCounter i 0
lappend result [! clsCounter counter i]
} -result {-157 0}
test methods-1.1 {} {*}$counterSetupAndCleanup -body {
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
} -result {1 99 99 99 {i 99}}
test object-copies-1.1 {} {*}$counterSetupAndCleanup -body {
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]
} -result {99 100 99}
test checked-values-1.1 {} {*}$counterSetupAndCleanup -body {
lappend result [! clsCheckedCounter counter i]
lappend result [! clsCheckedCounter counter i 5]
lappend result [! clsCheckedCounter counter incr]
} -result {0 5 6}
test checked-values-1.2 {get wrong type} {*}$counterSetupAndCleanup -body {
set counter {i hello}
! clsCheckedCounter counter i } -returnCodes error -result {value hello is not integer}
test checked-values-1.3 {set wrong type} {*}$counterSetupAndCleanup -body {
set counter {i 5}
! clsCheckedCounter counter i 3.14159 } -returnCodes error -result {value 3.14159 is not integer}
test checked-values-2.1 {} {*}$checkedListSetupAndCleanup -body {
! clsCheckedList checkedList data {1 2 3}
! clsCheckedList checkedList data
} -result {1 2 3}
test checked-values-2.2 {} {*}$checkedListSetupAndCleanup -body {
! clsCheckedList checkedList data \{ } -returnCodes error -result {value \{ is not list}
test checked-values-2.3 {} {*}$checkedListSetupAndCleanup -body {
apply {{obj cls} {
! cls obj data {foo bar baz}
}} $checkedList $clsCheckedList
} -result {foo bar baz}
test checked-values-2.4 {} {*}$checkedListSetupAndCleanup -body {
with-classes {clsCheckedList checkedList} {
!! checkedList label aribrary
!! checkedList label
}
} -result aribrary
test checked-values-3.0 {enums} -cleanup {
unset class object result
} -body {
set class [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] } -result {{value MAROON not in enum {RED GREEN BLUE UNKNOWN}} RED BLUE}
test checked-values-4.0 {validators} -cleanup {
unset class object result
} -body {
set class [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] } -result {{value 95 fails validator {y {expr {$y >= 100}}}} 100 1000}
test with-classes-1.1 {} {*}$counterSetupAndCleanup -body {
with-classes {clsCounter counter} {
lappend result [!! counter i]
!! counter incr
lappend result [!! counter i]
!! counter i 108
lappend result [!! counter i]
}
} -result {0 1 108}
set success [expr {$tcltest::numTests(Failed) == 0}]
tcltest::cleanupTests
return $success
}
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
Counting up to 10000 5 times.
dict: 2703.8 microseconds per iteration
counter field: 69268.6 microseconds per iteration
checked counter field: 115274.8 microseconds per iteration
with-classes counter field: 139264.0 microseconds per iteration
with-classes checked counter field: 190302.2 microseconds per iteration
counter method: 677381.2 microseconds per iteration
checked counter method: 775976.2 microseconds per iteration
with-classes counter method: 949686.2 microseconds per iteration
with-classes checked counter method: 1037058.0 microseconds per iteration
======
<<categories>> Object Orientation