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

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.5.2
    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 {![info exists me]} {
                set me {}
            }

            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

    if {![info exists classes]} {
        set classes [dict create]
    }

    set toRestore [dict create]
    set toUnset [list]
    dict for {class varNames} $mapping {
        foreach varName $varNames {
            if {[dict exists $classes $varName]} {
                dict set toRestore $varName [dict get $classes $varName]
            } else {
                lappend toUnset $varName
            }

            dict set classes $varName $class
        }
    }

    try {
        uplevel 1 $script
    } finally {
        # We do not just save and restore an old version of $classes because we
        # want to preserved changes unrelated to $mapping.
        set classes [dict merge $classes $toRestore]
        foreach varName $toUnset {
            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}

    test with-classes-1.2 -setup $setup {
        ::cyao::with-classes {clsCounter {c1 c2}} {
            set result [list ${%CLASSES%}]
            !! c1 incr 5
            !! c2 incr 7
            lappend result $c1 $c2
        }
    } -> {{c1 clsCounter c2 clsCounter} {i 5} {i 7}}

    test with-classes-1.3 -constraints !jim -setup $setup {
        set %CLASSES% [dict create o3 baz o6 qux]
        ::cyao::with-classes {foo {o1 o2} bar {o3 o4 o5}} {
            set result [list ${%CLASSES%}]
        }
        lappend result ${%CLASSES%}
    } -> {{o3 bar o6 qux o1 foo o2 foo o4 bar o5 bar} {o3 baz o6 qux}}

    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.

> 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