Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'

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