# -*- Tcl -*-
package require nx
package require nx::test

# just 8.6 or newer
if {[info command yield] eq ""} return

#
# Test coroutine / yield
#
nx::test case number-generator {
  nx::Object create ::numbers {
    # set instance variable used in coroutine
    set :delta 2
    :public object method ++ {} {
      yield
      set i 0
      while 1 {
	yield $i
	incr i ${:delta}
      }
    }
  }
  # create coroutine
  coroutine nextNumber ::numbers ++
  set ::j 0
  # use coroutine
  for {set i 0} {$i < 10} {incr i} {
    incr ::j [nextNumber]
  }

  # remove coroutine
  rename nextNumber {}

  ? {set ::j} 90
}

#
# Test coroutine / yield 
#
nx::test case enumerator1 {

  #
  # enumerator with yield in a single class
  #
  nx::Class create Enumerator {
    :property members:0..n
    :public method yielder {} {
      yield [info coroutine]
      foreach m ${:members} {
	yield $m
      }
      return -level 2 -code break
    }
    :public method next {} {${:coro}}
    :method init {} {
      :require namespace
      set :coro [coroutine [self]::coro [self] yielder]
    }
  }
  
  #
  # Some application class using the enumerator (just used for easy
  # testing)
  #
  nx::Class create Foo {
    :public method sum {} {
      set sum 0
      set e [Enumerator new -members {1 2 3}]
      while 1 {
	incr sum [$e next]
      }
      return $sum
    }
    :create f1
  }
  
  ? {f1 sum} 6
}


nx::test case enumerator2 {
  
  #
  # Define separate classes for Yielder and Enumerator
  #
  nx::Class create Yielder {
    :property {block ";"}
    :variable continuation ""

    #
    # make apply available as a method
    #
    :public alias apply ::apply

    #
    # The method "yielder" is the working horse for next. We need this
    # since the interface of Tcl's coroutines is based on a separate
    # cmd for continuation in the coroutine. The block can be
    # configured by application classes.
    #
    :public method yielder {} {
      yield [info coroutine]
      eval ${:block}
      return -level 2 -code break
    }

    #
    # The method "next" simply forwards to the continuation
    #
    :public method next {} {${:continuation}}

    #
    # The method "each" is based on the method "next" and applies the
    # value returned by next to the lambda expression
    #
    :public method each {var body} {
      while 1 {
	uplevel [list set $var [:next]]
	uplevel $body
      }
    }

    #
    # When a yielder is generated, we create automatically a coroutine
    # for it. The coroutine is placed under the current object, this
    # ensures simple cleanup (but is most probably not the fastest
    # variant, since we have to require a namespace).
    #
    :method init {} {
      :require namespace
      set :continuation [coroutine [self]::coro [self] yielder]
    }
  }

  #
  # The class "Enumerator" provides some application logic for the
  # class "Yielder". We use here a list of elements as base
  # representation.
  #
  nx::Class create Enumerator -superclass Yielder {
    :property members:0..n
    :property {block {
      foreach m ${:members} { yield $m }
    }}
  }

  #
  # Some application class using the enumerator (just used for easy
  # testing)
  #
  nx::Class create Foo {

    # test Enumerator.next
    :public method sum {} {
      set sum 0
      set e [Enumerator new -members {1 2 3}]
      while 1 { incr sum [$e next] }
      return $sum
    }
    
    :public method set {var} {
      set :$var
    }

    # test Enumerator.each
    :public method concat {} {
      set string "-"
      set i 0
      set e [Enumerator new -members {a be bu}]
      $e each x { append string $x-([incr i])- }
      return $string
    }
    
    :create f1
  }
  
  ? {f1 sum} 6
  ? {f1 concat} "-a-(1)-be-(2)-bu-(3)-"


  #
  # Define a class ATeam that uses "Enumerator", refines the method
  # "each" and adds another method "concat"
  #
  nx::Class create ATeam -superclass Enumerator {
    #
    # Overload "each" to show overloading. Here, we simply capitalize
    # the members in the "each" method.
    #
    :public method each {var body} {
      while 1 {
	set value [string totitle [:next]]
	uplevel [list set $var $value]
	uplevel $body
      }
    }
    # Define some arbitrary method using ATeam.each
    :public method concat {} {
      set string "-"
      :each x { append string $x- }
      return $string
    }
  }
  ATeam create a1 -members {alice bob caesar}
  ? {a1 concat } "-Alice-Bob-Caesar-"
}

#
# apply
#
nx::test case apply {

  # Register apply as an alias
  ::nx::Object public alias apply ::apply

  ::nx::Object create o {
    # Set an object variable
    set :delta 100

    # Define a standard map function based on apply
    :public object method map {lambda values} {
      set result {}
      foreach value $values {
	lappend result [:apply $lambda $value]
      }
      return $result
    }

    :object method foo {x} {return $x-$x}
  }

  # Two examples from the apply man page
  ? {o map {x {return [string length $x]:$x}} {a bb ccc dddd}} \
      "1:a 2:bb 3:ccc 4:dddd"
  ? {o map {x {expr {$x**2 + 3*$x - 2}}} {-4 -3 -2 -1 0 1 2 3 4}} \
      "2 -2 -4 -4 -2 2 8 16 26"

  ## Test case accessing object specific variable
  #? {o map {x {::nsf::__db_show_stack; return [expr {$x * ${:delta}}]}} {-4 -3 -2 -1 0 1 2 3 4}} \
  #    "-400 -300 -200 -100 0 100 200 300 400"

  # Test case accessing object specific variable
  ? {o map {x {expr {$x * ${:delta}}}} {-4 -3 -2 -1 0 1 2 3 4}} \
      "-400 -300 -200 -100 0 100 200 300 400"

  # Test case calling own method via apply
  ? {o map {x {:foo $x}} {hello world}} \
      "hello-hello world-world"
}


#
# The corrected cmd-literal semantics regarding cmd resolvers will
# only be released starting from and including 8.6.7.
#
if {![package vsatisfies [package req Tcl] 8.6.7]} {return}

set tcl87 [package vsatisfies [package req Tcl] 8.7]

nx::test case bug-3418547 {
  #
  # See http://core.tcl.tk/tcl/tktview?name=3418547fff
  # 

  ? {info commands "::@"} ""

  proc getType {x} {dict get [::nsf::__db_get_obj @] type}

  ? {getType @} ""            ;# "@" has no type
  ? {namespace which @} ""
  if {!$::tcl87} {
      ? {getType @} "cmdName"     ;# "@" is of type "cmdName"
  }
  
  ? {@} {invalid command name "@"}
  ? {getType @} "bytecode"    ;# "@" is of type "bytecode"  

  
  #
  # 1) Provide @ for interp resolver in NX root namespace
  #
  proc ::nx::@ {} {
    return ::nx::@
  }

  nx::Object create ::o {
    :public object method foo {} {
      @; # Should resolve against ::nx::@ (by interp resolver)
    }
  }

  ? {getType @} "bytecode"        ;# "@" is still of type "bytecode"
  ::o foo
  ? {getType @} "bytecode"        ;# "@" is still of type "bytecode"  (byte code compilation should not leak)

  ? {::o foo} ::nx::@             ;# "@" is resolved in the nx context, therefore we get nx::@
  
  #
  # 2) Provide alternative @
  #
  proc ::@ {} {
    return ::@
  }
  
  ? {info commands ::@} "::@"
  ? {::@} ::@
  ? {getType @} "bytecode"        ;# "@" is still of type "bytecode"

  set x [@]                       ;# execute "@" in an nx environment ("eval" of the test case)
  ? {getType @} "cmdName"         ;# "@" is of type "cmdName"

  ? [list $x] ::nx::@
  
  ? @ ::@                         ;# proc "?" interprets "@" as a script and turns "@"
                                  ;# into type "bytecode". The proc leaves the nx context
                                  ;# by using a "namespace eval", therefore we see ::@
  ? {getType @} "bytecode"        ;# "@" is of type "bytecode"
  
  ? {namespace eval :: @} ::@     ;# exercise the same "namespace eval" as described above
  ? {namespace eval :: ::@} ::@   ;# the same with the global namespace qualifier
  
  ? {getType @} "bytecode"        ;# "@" is of type "bytecode"
  ? {getType ::@} "bytecode"      ;# "::@" is of type "bytecode"
  
  ? {namespace origin @} ::@      ;# "namespace origin" converts literal "@" from "bytecode" to "cmdName"
  ? {getType @} "cmdName"

  ? {namespace origin ::@} ::@
  ? {getType @}   "cmdName"
  ? {getType ::@} "cmdName"
  
  ? {@} ::@                   ;# the result is still the same as everywhere, since we are in an nx context XXX
}

#
# Without nx context
#
nx::test case bug-3418547-no-context
proc getType {x} {dict get [::nsf::__db_get_obj @] type}

# delete the commands
rename @ ""
rename ::nx::@ ""

? {info commands "::@"} ""

? {getType @}   ""
? {namespace which @} ""
if {!$::tcl87} {
    ? {getType @}   "cmdName"
}

? {@} {invalid command name "@"}

#
# 1) Provide proc @
#
proc ::@ {} {
  return ::@
}

? {@} ::@
if {!$::tcl87} {
    ? {getType @}   "cmdName"
}

#
# 2) Provide @ for interp resolver in NX root namespace
#
proc ::nx::@ {} {
  return ::nx::@
}

set r [@]       ;# "@" is not executed in an nx environment (no testcase eval), therefore resolved globally
? {set r} ::@
if {!$::tcl87} {
    ? {getType @}   "cmdName"
}

nx::Object create ::o {
  :public object method foo {} {
    @          ; # resolve against ::nx::@ (via interp resolver)
  }
}

set r [::o foo]
? {set r} ::nx::@
if {!$::tcl87} {
    ? {getType @}   "cmdName"
}

? {::o foo} ::nx::@

set r [@]       ;# "@" is not executed in an nx environment (no testcase eval), therefore resolves globally
? {set r} ::@
? {@} ::@       ;# "@" is executed in an "namespace eval ::", therefore no nx context

# cleanup
rename ::nx::@ ""
rename @ ""


#
# Try to reconstruct test case of Tcl's resolver.test 1.6
#
nx::test case resolver-1.6

proc ::@@ {} {return ::@@}
proc ::nx::@ {} {
  return ::nx::@
}

nx::Object create ::o {
  :public object method foo {} {
    @          ; # resolve against ::nx::@ (via interp resolver)
  }
}

set r [::o foo]
? {set r} ::nx::@

interp alias {} ::nx::@ {} ::@@

# call the new aliased definition
? {::nx::@} ::@@

# see consistent results from method foo
set r [::o foo]
? {set r} ::@@