Classy YAO

Difference between version 6 and 9 - Previous - Next

[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.45.02
    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
    dictf {![infor {exists class varNames]} $mapping {
        dict set classes $varName[dict $clreasste]
    }
    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 dico not fjust 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.

======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
======

<<categories>> Jim Package | Object Orientation