Classy YAO

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, [enums], or apply lambdas.

Code edit

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.2
    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 edit

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 edit

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.

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

Category Object Orientation