diff options
Diffstat (limited to 'tcllib/modules/oodialect')
| -rw-r--r-- | tcllib/modules/oodialect/oodialect.demo | 62 | ||||
| -rw-r--r-- | tcllib/modules/oodialect/oodialect.md | 63 | ||||
| -rw-r--r-- | tcllib/modules/oodialect/oodialect.tcl | 245 | ||||
| -rw-r--r-- | tcllib/modules/oodialect/oodialect.test | 162 | ||||
| -rw-r--r-- | tcllib/modules/oodialect/pkgIndex.tcl | 11 |
5 files changed, 543 insertions, 0 deletions
diff --git a/tcllib/modules/oodialect/oodialect.demo b/tcllib/modules/oodialect/oodialect.demo new file mode 100644 index 0000000..6d08e09 --- /dev/null +++ b/tcllib/modules/oodialect/oodialect.demo @@ -0,0 +1,62 @@ +set here [file dirname [file join [pwd] [info script]]]
+set auto_path [linsert $auto_path 0 [file dirname $here]]
+
+package require oo::meta
+package require oo::dialect
+oo::dialect::create tool
+
+# Add a new keyword
+proc ::tool::define::option {name def} {
+ set class [current_class]
+ oo::meta::info $class branchset option $name $def
+}
+
+# Override the "constructor" keyword
+proc ::tool::define::constructor {arglist body} {
+ set class [current_class]
+ puts [list CONSTRUCTOR for $class]
+ set prebody {
+puts [list CREATED [self]]
+my _optionInit
+ }
+ oo::define $class constructor $arglist "$prebody\n$body"
+}
+
+# Add functions to the core class
+::tool::define ::tool::object {
+ method _optionInit {} {
+ my variable options meta
+ if {![info exists meta]} {
+ set meta {}
+ }
+ foreach {opt info} [my meta getnull option] {
+ set options($opt) [dict getnull $info default:]
+ }
+ }
+ method cget option {
+ my variable options
+ return $options($option)
+ }
+}
+
+::tool::class create myclass {
+ # Use our new option keyword
+ option color {default: green}
+
+ constructor {} {
+ my variable meta
+ set meta {}
+ }
+}
+
+myclass create myobj
+puts [myobj cget color]
+
+source [file join $here .. tool dictobj.tcl]
+
+::tool::define myclass {
+ dictobj test test
+}
+
+myobj test set foo bar
+puts [myobj test get foo]
diff --git a/tcllib/modules/oodialect/oodialect.md b/tcllib/modules/oodialect/oodialect.md new file mode 100644 index 0000000..99f2063 --- /dev/null +++ b/tcllib/modules/oodialect/oodialect.md @@ -0,0 +1,63 @@ +The oo::dialect Package
+=======================
+
+*oo::dialect* is designed for building TclOO based domain specific languages. It does this
+by providing:
+* a meta class
+* a core object
+* A namespace in which to define additional keywords
+* A "define" command to mirror the capabilties of *oo::define*
+
+Example usage:
+<pre>
+<code>
+package require oo::dialect
+oo::dialect::create tool
+
+# Add a new keyword
+proc ::tool::define::option {name def} {
+ set class [class_current]
+ oo::meta::info $class branchset option $name $def
+}
+
+# Override the "constructor" keyword
+proc ::tool::define::constructor {arglist body} {
+ set class [class_current]
+ set prebody {
+my _optionInit
+ }
+ oo::define $class constructor $arglist "$prebody\n$body"
+}
+
+# Add functions to the core class
+::tool::define ::tool::object {
+ method _optionInit {} {
+ my variable options
+ foreach {opt info} [my meta getnull option] {
+ set options($opt) [dict getnull $info default:]
+ }
+ }
+ method cget option {
+ my variable options
+ return $options($option)
+ }
+}
+
+</code>
+</pre>
+
+In practice, a new class of this dialect would look like:
+
+<pre>
+<code>
+::tool::class create myclass {
+ # Use our new option keyword
+ option color {default: green}
+}
+
+myclass create myobj
+puts [myobj cget color]
+> green
+</code>
+</pre>
+
diff --git a/tcllib/modules/oodialect/oodialect.tcl b/tcllib/modules/oodialect/oodialect.tcl new file mode 100644 index 0000000..ee5fc8a --- /dev/null +++ b/tcllib/modules/oodialect/oodialect.tcl @@ -0,0 +1,245 @@ +### +# oodialect.tcl +# +# Copyright (c) 2015 Sean Woods, Donald K Fellows +# +# BSD License +### +# @@ Meta Begin +# Package oo::dialect 0.2 +# Meta platform tcl +# Meta summary A utility for defining a domain specific language for TclOO systems +# Meta description This package allows developers to generate +# Meta description domain specific languages to describe TclOO +# Meta description classes and objects. +# Meta category TclOO +# Meta subject oodialect +# Meta require {Tcl 8.6} +# Meta author Sean Woods +# Meta author Donald K. Fellows +# Meta license BSD +# @@ Meta End + +namespace eval ::oo::dialect { + namespace export create +} + +# A stack of class names +proc ::oo::dialect::Push {class} { + ::variable class_stack + lappend class_stack $class +} +proc ::oo::dialect::Peek {} { + ::variable class_stack + return [lindex $class_stack end] +} +proc ::oo::dialect::Pop {} { + ::variable class_stack + set class_stack [lrange $class_stack 0 end-1] +} + +### +# This proc will generate a namespace, a "mother of all classes", and a +# rudimentary set of policies for this dialect. +### +proc ::oo::dialect::create {name {parent ""}} { + set NSPACE [NSNormalize [uplevel 1 {namespace current}] $name] + ::namespace eval $NSPACE {::namespace eval define {}} + ### + # Build the "define" namespace + ### + if {$parent eq ""} { + ### + # With no "parent" language, begin with all of the keywords in + # oo::define + ### + foreach command [info commands ::oo::define::*] { + set procname [namespace tail $command] + interp alias {} ${NSPACE}::define::$procname {} \ + ::oo::dialect::DefineThunk $procname + } + # Create an empty dynamic_methods proc + proc ${NSPACE}::dynamic_methods {class} {} + namespace eval $NSPACE { + ::namespace export dynamic_methods + ::namespace eval define {::namespace export *} + } + set ANCESTORS {} + } else { + ### + # If we have a parent language, that language already has the + # [oo::define] keywords as well as additional keywords and behaviors. + # We should begin with that + ### + set pnspace [NSNormalize [uplevel 1 {namespace current}] $parent] + apply [list parent { + ::namespace export dynamic_methods + ::namespace import -force ${parent}::dynamic_methods + } $NSPACE] $pnspace + apply [list parent { + ::namespace import -force ${parent}::define::* + ::namespace export * + } ${NSPACE}::define] $pnspace + set ANCESTORS [list ${pnspace}::object] + } + ### + # Build our dialect template functions + ### + + proc ${NSPACE}::define {oclass args} [string map [list %NSPACE% $NSPACE] { + ### + # To facilitate library reloading, allow + # a dialect to create a class from DEFINE + ### + set class [::oo::dialect::NSNormalize [uplevel 1 {namespace current}] $oclass] + if {[info commands $class] eq {}} { + %NSPACE%::class create $class {*}${args} + } else { + ::oo::dialect::Define %NSPACE% $class {*}${args} + } + }] + interp alias {} ${NSPACE}::define::current_class {} \ + ::oo::dialect::Peek + interp alias {} ${NSPACE}::define::aliases {} \ + ::oo::dialect::Aliases $NSPACE + interp alias {} ${NSPACE}::define::superclass {} \ + ::oo::dialect::SuperClass $NSPACE + + if {[info command ${NSPACE}::class] ne {}} { + ::rename ${NSPACE}::class {} + } + ### + # Build the metaclass for our language + ### + ::oo::class create ${NSPACE}::class { + superclass ::oo::dialect::MotherOfAllMetaClasses + } + # Wire up the create method to add in the extra argument we need; the + # MotherOfAllMetaClasses will know what to do with it. + ::oo::objdefine ${NSPACE}::class \ + method create {name {definitionScript ""}} \ + "next \$name [list ${NSPACE}::define] \$definitionScript" + + ### + # Build the mother of all classes. Note that $ANCESTORS is already + # guaranteed to be a list in canonical form. + ### + uplevel #0 [string map [list %NSPACE% [list $NSPACE] %name% [list $name] %ANCESTORS% $ANCESTORS] { + %NSPACE%::class create %NSPACE%::object { + superclass %ANCESTORS% + # Put MOACish stuff in here + } + }] +} + +# Support commands; not intended to be called directly. +proc ::oo::dialect::NSNormalize {namespace qualname} { + if {![string match ::* $qualname]} { + set qualname ${namespace}::$qualname + } + regsub -all {::+} $qualname "::" +} + +proc ::oo::dialect::DefineThunk {target args} { + tailcall ::oo::define [Peek] $target {*}$args +} + +proc ::oo::dialect::Canonical {namespace NSpace class} { + namespace upvar $namespace cname cname + if {[string match ::* $class]} { + return $class + } + if {[info exists cname($class)]} { + return $cname($class) + } + if {[info exists ::oo::dialect::cname($class)]} { + return $::oo::dialect::cname($class) + } + foreach item [list "${NSpace}::$class" "::$class"] { + if {[info command $item] ne {}} { + return $item + } + } + return ${NSpace}::$class +} + +### +# Implementation of the languages' define command +### +proc ::oo::dialect::Define {namespace class args} { + Push $class + try { + if {[llength $args]==1} { + namespace eval ${namespace}::define [lindex $args 0] + } else { + ${namespace}::define::[lindex $args 0] {*}[lrange $args 1 end] + } + ${namespace}::dynamic_methods $class + } finally { + Pop + } +} + +### +# Implementation of how we specify the other names that this class will answer +# to +### + +proc ::oo::dialect::Aliases {namespace args} { + set class [Peek] + namespace upvar $namespace cname cname + set NSpace [join [lrange [split $class ::] 1 end-2] ::] + set cname($class) $class + foreach name $args { + set alias $name + #set alias [NSNormalize $NSpace $name] + # Add a local metaclass reference + set cname($alias) $class + if {![info exists ::oo::dialect::cname($alias)]} { + ## + # Add a global reference, first come, first served + ## + set ::oo::dialect::cname($alias) $class + } + } +} + +### +# Implementation of a superclass keyword which will enforce the inheritance of +# our language's mother of all classes +### + +proc ::oo::dialect::SuperClass {namespace args} { + set class [Peek] + namespace upvar $namespace class_info class_info + dict set class_info($class) superclass 1 + set ::oo::dialect::cname($class) $class + set NSpace [join [lrange [split $class ::] 1 end-2] ::] + set unique {} + foreach item $args { + set Item [Canonical $namespace $NSpace $item] + dict set unique $Item $item + } + set root ${namespace}::object + if {$class ne $root} { + dict set unique $root $root + } + tailcall ::oo::define $class superclass {*}[dict keys $unique] +} + +### +# Implementation of the common portions of the the metaclass for our +# languages. +### + +::oo::class create ::oo::dialect::MotherOfAllMetaClasses { + superclass ::oo::class + constructor {define definitionScript} { + $define [self] { + superclass + } + $define [self] $definitionScript + } +} + +package provide oo::dialect 0.3
\ No newline at end of file diff --git a/tcllib/modules/oodialect/oodialect.test b/tcllib/modules/oodialect/oodialect.test new file mode 100644 index 0000000..b568ec7 --- /dev/null +++ b/tcllib/modules/oodialect/oodialect.test @@ -0,0 +1,162 @@ +# tool.test - Copyright (c) 2015 Sean Woods +# ------------------------------------------------------------------------- + +source [file join \ + [file dirname [file dirname [file join [pwd] [info script]]]] \ + devtools testutilities.tcl] + +testsNeedTcl 8.6 +testsNeedTcltest 2 +testsNeed TclOO 1 + +support { + use dicttool/dicttool.tcl dicttool + use oometa/oometa.tcl oo::meta +} +testing { + useLocal oodialect.tcl oo::dialect +} + +# ------------------------------------------------------------------------- + +::oo::dialect::create ::alpha + +proc ::alpha::define::is_alpha {} { + dict set ::testinfo([current_class]) is_alpha 1 +} + +::alpha::define ::alpha::object { + is_alpha +} + +::oo::dialect::create ::bravo ::alpha + +proc ::bravo::define::is_bravo {} { + dict set ::testinfo([current_class]) is_bravo 1 +} + +::bravo::define ::bravo::object { + is_bravo +} + +::oo::dialect::create ::charlie ::bravo + +proc ::charlie::define::is_charlie {} { + dict set ::testinfo([current_class]) is_charlie 1 +} + +::charlie::define ::charlie::object { + is_charlie +} + +::oo::dialect::create ::delta ::charlie + +proc ::delta::define::is_delta {} { + dict set ::testinfo([current_class]) is_delta 1 +} + +::delta::define ::delta::object { + is_delta +} + +::delta::class create adam { + is_alpha + is_bravo + is_charlie + is_delta +} + +test oodialect-keyword-001 {Testing keyword application} { + set ::testinfo(::adam) +} {is_alpha 1 is_bravo 1 is_charlie 1 is_delta 1} + +test oodialect-keyword-002 {Testing keyword application} { + set ::testinfo(::alpha::object) +} {is_alpha 1} + +test oodialect-keyword-003 {Testing keyword application} { + set ::testinfo(::bravo::object) +} {is_bravo 1} + +test oodialect-keyword-004 {Testing keyword application} { + set ::testinfo(::charlie::object) +} {is_charlie 1} + +test oodialect-keyword-005 {Testing keyword application} { + set ::testinfo(::delta::object) +} {is_delta 1} + +### +# Declare an object from a namespace +### +namespace eval ::test1 { + ::alpha::class create a { + aliases A + is_alpha + } + ::alpha::define b { + aliases B BEE + is_alpha + } + ::alpha::class create ::c { + aliases C + is_alpha + } + ::alpha::define ::d { + aliases D + is_alpha + } +} + +test oodialect-naming-001 {Testing keyword application} { + set ::testinfo(::test1::a) +} {is_alpha 1} + +test oodialect-naming-002 {Testing keyword application} { + set ::testinfo(::test1::b) +} {is_alpha 1} + +test oodialect-naming-003 {Testing keyword application} { + set ::testinfo(::c) +} {is_alpha 1} + +test oodialect-naming-004 {Testing keyword application} { + set ::testinfo(::d) +} {is_alpha 1} + +test oodialect-aliasing-001 {Testing keyword application} { +namespace eval ::test1 { + ::alpha::define e { + superclass A + } +} +} ::test1::e + +test oodialect-aliasing-002 {Testing keyword application} { +namespace eval ::test1 { + ::bravo::define f { + superclass A + } +} +} ::test1::f + +test oodialect-ancestry-001 {Testing heritage} { + ::oo::meta::ancestors ::test1::f +} {::oo::object ::alpha::object ::bravo::object ::test1::a ::test1::f} + +test oodialect-ancestry-001 {Testing heritage} { + ::oo::meta::ancestors ::alpha::object +} {::oo::object ::alpha::object} + +test oodialect-ancestry-001 {Testing heritage} { + ::oo::meta::ancestors ::delta::object +} {::oo::object ::alpha::object ::bravo::object ::charlie::object ::delta::object} +# ------------------------------------------------------------------------- + + +testsuiteCleanup + +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/tcllib/modules/oodialect/pkgIndex.tcl b/tcllib/modules/oodialect/pkgIndex.tcl new file mode 100644 index 0000000..3285f10 --- /dev/null +++ b/tcllib/modules/oodialect/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script. It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands. When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+package ifneeded oo::dialect 0.3 [list source [file join $dir oodialect.tcl]]
|