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

#
# test cases for disposition "alias" and "forward"
#

nx::Test case basics {

  Class create C {
    :class attribute [list inst "::__%&singleton"]
    :method foo {x} {
      #puts stderr [current method]
      set :[current method] $x
    }
    :method bar {} {;}
    :protected method baz {y} {
      #puts stderr [current method]
      set :my[current method] $y
    }

    #
    # some testing helpers
    #
    :public class method setObjectParams {spec} {
      set :objectparams $spec
      ::nsf::invalidateobjectparameter [current]
    }
    :class method objectparameter {} {
      return ${:objectparams} 
    }
    :setObjectParams ""

    :public class method new args {
      return [:create ${:inst} {*}$args]
    }
  }

  foreach paramType {forward alias} {
    #
    # Restricted to object parameters only?
    #
    set msg "Parameter option '$paramType' not allowed"
    ? [list C method m1 -foo:$paramType {;}] $msg
    ? [list C method m1 foo:$paramType {;}] $msg
    
    #
    # Not applicable in parametercheck
    #
    ? [list ::nsf::is $paramType $msg] "invalid value constraints \"$paramType\""
  }

  
  #
  # Do aliases and forwarder set instance variables? They should not.
  #
  C setObjectParams -baz:alias
  ? {[C new -baz BAZ] eval {info exists :baz}} 0

  C setObjectParams {{{-baz:forward,method=%self %method}}}
  ? {[C new -baz BAZ] eval {info exists :baz}} 0

  #
  # Note, currently alias/forward disposition operate on public and
  # protected target methods alike. Is this intended? For example,
  # providing access through the parameter interface to protected
  # methods etc. (at the instantiation site only) ? Or, are they
  # expected to be public ... 
  #
  ### objectparameter are from the intentions public: the typical
  ### use-case is that someone wants to configure an object to be
  ### created, before the object exists.... 

  #
  # 1) Positional object parameters + alias/forward disposition?
  #

  #
  # Passing a single argument to a positional alias
  #
  C setObjectParams foo:alias
  ? {C new FOO} "::__%&singleton"
  ? {C new {FOO FAA}} "::__%&singleton"

  ###
  ### Whenever a value is provided (default value or actual value) the
  ### parameter is evaluated.
  ###
  C setObjectParams {{foo:alias ""}}
  ? {C new} "::__%&singleton"

  C setObjectParams {{-foo:alias "fooDefault"}}
  ? {[C new] eval {set :foo}} "fooDefault"

  #
  # What about multi-argument vectors?
  #

  C eval {
    :method multi-2 {x y} {
      set :[current method] [current args]
    }
    :method multi-escape {x} {
      set :[current method] $x
    }
    :method multi-args {args} {
      set :[current method] $args
    }
  }

  #
  # Parameters are limited to a single value by the object parameter.
  #

  C setObjectParams {{-multi-2:alias}}
  ? {[C new -multi-2 {X Y}] eval {set :multi-2}} \
      "wrong # args: should be \"multi-2 x y\""
  #
  # Passing multiple arguments as a list
  #
  C setObjectParams {{-multi-escape:alias}}
  ? {[C new -multi-escape [list X Y]] eval {set :multi-escape}} \
      [list X Y]

  #
  # Passing multiple arguments as a list, passed to a args argument
  # list.
  #
  C setObjectParams {{-multi-args:alias}}
  ? {[C new -multi-args [list X Y]] eval {set :multi-args}} \
      [list [list X Y]]

  #
  # By design, all parameters are currently limited to 0 or 1
  # argument.  The same is true for disposition "alias" an
  # "forward". One could consider to unbox a parameter list via a
  # parameter option "expand" (like {*}) for alias|forward parameter
  # specs, e.g.:
  # {-multi-2:alias,expand}
  # {-multi-2:forward,method=...,expand}
  #
  # Without the sketched extension, one could use eval in a forwarder.
  # 

  C setObjectParams {{{-multi-2:forward,method=eval %self %method}}}
  ? {[C new -multi-2 {X Y}] eval {set :multi-2}} \
      "X Y"

  #
  # In the positional case, why is FOO not passed on as arg value to
  # the target method?
  #
  C setObjectParams {{{foo:forward,method=%self %method}}}
  ? {C new FOO} "::__%&singleton"
  ? {[C new FOO] eval {set :foo}} "FOO"

  #
  # Naming of the parameter spec element "method": It fits the alias
  # disposition, but is a little irritating in the context of a
  # forward. One would expect forwardspec or simply "spec" (as this is
  # used in the docs, the error messages etc.), e.g.:
  #
  # {foo:forward,spec=%self %method}
  #
  # 'spec' would also work for 'alias' as it is more general (the spec
  # of an alias is the method name ...)
  #
  #### well, "spec" is not nice for alias, and potentially confusing
  #### with the parameter spec (the full parameter definition).

  #
  # Passing non-positional arguments to target methods (at least
  # forwarder ones)?
  #

  C method multi-mix {-x y args} {
    set :[current method] --x-$x--y-$y--args-$args
  }

  C setObjectParams {{{-multi-mix:forward,method=eval %self %method}}}
  ? {[C new -multi-mix [list -x X Y Z 1 2]] eval {set :multi-mix}} \
      "--x-X--y-Y--args-Z 1 2"

  #
  # Aliased methods with nonpos arguments are rendered entirely
  # useless by the single-value limitation (see also above):
  #

  C method single-np {-x:required} {
    set :[current method] --x-$x
  }

  C setObjectParams {{-single-np:alias}}
  ? {[C new -single-np [list -x]] eval {set :single-np}} \
      "Argument for parameter '-x' expected"
  ? {[C new -single-np [list -x X]] eval {set :single-np}} \
      "Invalid argument '-x X', maybe too many arguments; should be \"[C inst] single-np -x\""

  #
  # INTERACTIONS with other parameter types
  # 
  # There are two validation points:
  # 1) the object parameter validation on the initial argument set
  # 2) the target method validation on the (mangled) argument set
  #
  # ... they can deviate from each other, to a point of direct
  # conflict
  #

  #
  # Allowed built-in value types (according to feature matrix in
  # parameters.test)
  #

  set msg {expected $mtype but got \"$testvalue\" for parameter \"x\"}
  dict set types boolean [list testvalue f mtype object msg $msg]
  dict set types integer [list testvalue 81 mtype punct msg $msg]
  dict set types object [list testvalue ::C mtype integer msg $msg ]
  
  dict set types class [list testvalue ::C mtype boolean msg $msg]
  dict set types object,type=::nx::Class \
      [list testvalue ::C  mtype object,type=::C \
	   msg "expected object of type ::C but got \"::C\"\
		for parameter \"x\""] 

  # for aliases ...
  
  dict for {t tdict} $types {
    dict with tdict {
      ::C public method foo [list x:$t] {
	set :[current method] $x
      }
      ::C setObjectParams [list [list -foo:alias,$t]]
      ? "::nsf::is $t \[\[::C new -foo $testvalue\] eval {set :foo}\]" 1 "check: -foo:alias,$t"
    }
  }

  ::C public method baz {x} {
    return $x
  }

  dict for {t tdict} $types {
    dict with tdict {
      ::C public method foo [list x:$mtype] {
	set :[current method] $x
      }
      ::C setObjectParams [list [list -foo:alias,$t]]
      ? "::nsf::is $t \[\[::C new -foo $testvalue\] eval {set :foo}\]" \
      	  [subst $msg]
    }
  }

  # 
  # TODO: update the matrix in parameters.test (feature matrix)
  #
  ###
  ### The question is, what happens with the matrix. The matrix is in
  ### some respects not complete (no disposition) and contains old
  ### namings (e.g. allowempty, multiple) and contains types removed
  ### some time ago (such as e.g. "relation").
  ###

  #
  # define a user defined parameter type
  #
  ::nx::methodParameterSlot method type=mytype {name value} {
    if {$value < 1 || $value > 3} {
      error "Value '$value' of parameter $name is not between 1 and 3"
    }
  }

  array set script {alias "method=baz" forward "method=%self %method"}
  foreach disposition [list alias forward] {
    C setObjectParams [list [list -foo:$disposition,switch]]
    ? {C new} "Parameter option 'switch' not allowed" \
	"switch not allowed for $disposition"
    
    C setObjectParams [list [list -baz:$disposition,mytype,$script($disposition)]]
    ? {C new -baz 1} "::__%&singleton" \
	"disposition $disposition, user defined type, valid value"

    C setObjectParams [list [list -baz:$disposition,mytype,$script($disposition)]]
    ? {C new -baz 0} "Value '0' of parameter baz is not between 1 and 3" \
	"disposition $disposition, user defined type, invalid value"

    C setObjectParams [list [list -foo:$disposition,xxx]]
    ? {C new} "::__%&singleton" \
	"disposition $disposition, unknown user defined type - just a warning"

    C setObjectParams [list [list -foo:$disposition,type=::C]]
    ? {C new} "Parameter option 'type=' only allowed for parameter types 'object' and 'class'"

    #
    # The 'arg=...' option should not be used, consider using 'method=...'
    #
    C setObjectParams [list [list -foo:$disposition,arg=BOOM]]
    ? {C new} "Parameter option 'arg=' only allowed for user-defined converter"

  }

  #
  # The option 'method=...' applies to disposition types only
  #
  C setObjectParams [list [list -foo:initcmd,method=BOOM]]
  ? {C new} "Parameter option 'method=' only allowed for parameter types 'alias' and 'forward'"
  
  C setObjectParams [list [list -foo:alias,forward]]
  ? {C new} "Parameter types 'alias' and 'forward' can be not used together"

  C setObjectParams [list [list -foo:forward,alias]]
  ? {C new} "Parameter types 'alias' and 'forward' can be not used together"

  C setObjectParams [list [list -foo:alias,initcmd]]
  ? {C new} "Parameter types 'alias' and 'initcmd' can be not used together"

  C setObjectParams [list [list -foo:forward,initcmd]]
  ? {C new} "Parameter types 'forward' and 'initcmd' can be not used together"


  # Remains to be done ...
  # INTERACTIONS with the return value checker
  #
  
  #
  # uplevel, upvar (with forward, with different target method types)
  #

  # 
  # allowempty
  # 
}

nx::Test case dispo-multiplicities {
  Class create S {
    :public class method setObjectParams {spec} {
      set :objectparams $spec
      ::nsf::invalidateobjectparameter [current]
    }
    :class method objectparameter {} {
      return ${:objectparams} 
    }
    :public method foo {args} {
      set :foo $args
      return $args
    }
  }

  #
  # On multiplicity classes ...
  # 
  # ... implying a Tcl list value: 1..*, 0..* 
  # ... implying a Tcl word value: 1..1, 0..1
  #

  S setObjectParams {-foo:alias,1..*,boolean}
  S method foo {x:0..1,boolean} {
    set :foo $x
  }
  ? {[S new -foo [list f f]] eval {info exists :foo}} \
      "expected boolean but got \"f f\" for parameter \"x\""

  S setObjectParams {-foo:alias,1..*,integer}
  S method foo {x:1..1,integer} {
    set :foo $x
  }
  ? {[S new -foo [list a 1]] eval {info exists :foo}} \
      "invalid value in \"a 1\": expected integer but got \"a\" for parameter \"-foo\""
  ? {[S new -foo [list 0 1]] eval {info exists :foo}} \
      "expected integer but got \"0 1\" for parameter \"x\""
  ? {[S new -foo [list]] eval {info exists :foo}} \
      "invalid parameter value for -foo: list is not allowed to be empty"
  ? {[S new -foo 5] eval {info exists :foo}} 1
  ? {[S new -foo f] eval {info exists :foo}} \
      "invalid value in \"f\": expected integer but got \"f\" for parameter \"-foo\""

  S setObjectParams {-foo:alias,0..*,false}
  S method foo {x:0..1,false} {
    set :foo $x
  }

  ? {[S new -foo [list a 1]] eval {info exists :foo}} \
      "invalid value in \"a 1\": expected false but got \"a\" for parameter \"-foo\""

  ? {[S new -foo [list f 0]] eval {info exists :foo}} \
      "expected false but got \"f 0\" for parameter \"x\""

  ? {[S new -foo [list t]] eval {info exists :foo}} \
      "invalid value in \"t\": expected false but got \"t\" for parameter \"-foo\""

  ? {[S new -foo [list f]] eval {info exists :foo}} 1

  ? {[S new -foo [list]] eval {info exists :foo}} 1

}

nx::Test case alias-noarg {
  Class create C {
    :public class method setObjectParams {spec} {
      set :objectparams $spec
      ::nsf::invalidateobjectparameter [current]
    }
    :class method objectparameter {} {
      return ${:objectparams} 
    }
    :public method foo {args} {
      set :foo $args
      #puts stderr FOO
      return $args
    }
    :public method bar {args} {
      set :bar $args
      #puts stderr BAR
      return $args
    }
  }

  #
  # nopos arg with noargs, given
  #
  C setObjectParams {-bar:alias,noarg}
  C create c1 -bar
  ? {c1 eval {info exists :bar}} 1
  ? {c1 eval {info exists :x}} 0

  #
  # nopos arg with noargs, not given
  #
  C setObjectParams {-bar:alias,noarg}
  C create c1
  ? {c1 eval {info exists :bar}} 0

  #
  # pos arg with noargs
  #
  C setObjectParams {foo:alias,noarg}
  C create c1
  ? {c1 eval {info exists :foo}} 1

  #
  # initcmd with default
  #
  C setObjectParams {{__init:initcmd :foo}}
  C create c1
  ? {c1 eval {info exists :foo}} 1

  #
  # pos arg with noargs and nonposarg with noargs, given
  #
  C setObjectParams {foo:alias,noarg -bar:alias,noarg}
  C create c1 -bar
  ? {c1 eval {info exists :bar}} 1
  ? {c1 eval {info exists :foo}} 1
  ? {c1 eval {info exists :x}} 0

  #
  # optional initcmd, like in nx
  #
  C setObjectParams {initcmd:initcmd,optional}
  C create c1 {set :x 1}
  ? {c1 eval {info exists :x}} 1

  #
  # using a default value for initcmd
  #
  C setObjectParams {{initcmd:initcmd ""}}
  C create c1 {set :x 1}
  C create c2
  ? {c1 eval {info exists :x}} 1
  ? {c2 eval {info exists :x}} 0

  #
  # optional initcmd + non-consuming (nrargs==0) posarg, provided
  # initcmd
  #
  C setObjectParams {foo:alias,noarg initcmd:initcmd,optional}
  C create c1 {set :x 1}
  ? {c1 eval {info exists :x}} 1
  ? {c1 eval {info exists :foo}} 1
  ? {c1 eval {info exists :bar}} 0

  #
  # optional initcmd + non-consuming (nrargs==0) posarg, no value for
  # initcmd
  #
  C setObjectParams {foo:alias,noarg initcmd:initcmd,optional}
  C create c1
  ? {c1 eval {info exists :x}} 0
  ? {c1 eval {info exists :foo}} 1
  ? {c1 eval {info exists :bar}} 0

  #
  # initcmd with default + non-consuming (nrargs==0) posarg, no value
  # for initcmd
  #
  C setObjectParams {foo:alias,noarg {initcmd:initcmd ""}}
  C create c1
  ? {c1 eval {info exists :x}} 0
  ? {c1 eval {info exists :foo}} 1
  ? {c1 eval {info exists :bar}} 0

  #
  # non-consuming alias, nonpos alias with noarg, initcmd provided
  #
  C setObjectParams {foo:alias,noarg -bar:alias,noarg initcmd:initcmd,optional}
  C create c1 {set :x 1}
  ? {c1 eval {info exists :foo}} 1
  ? {c1 eval {info exists :bar}} 0
  ? {c1 eval {info exists :x}} 1

  #
  # non-consuming alias, nonpos alias with noarg, nonpos called, initcmd provided
  #
  C setObjectParams {foo:alias,noarg -bar:alias,noarg initcmd:initcmd,optional}
  C create c1 -bar {set :x 1}
  ? {c1 eval {info exists :foo}} 1
  ? {c1 eval {info exists :bar}} 1
  ? {c1 eval {info exists :x}} 1

  #
  # non-consuming alias, nonpos alias with noarg, no initcmd provided
  #
  C setObjectParams {foo:alias,noarg -bar:alias,noarg initcmd:initcmd,optional}
  C create c1
  ? {c1 eval {info exists :foo}} 1
  ? {c1 eval {info exists :bar}} 0
  ? {c1 eval {info exists :x}} 0

  #
  # non-consuming alias, nonpos alias with noarg, nonpos called, no
  # initcmd provided
  #
  C setObjectParams {foo:alias,noarg -bar:alias,noarg initcmd:initcmd,optional}
  C create c1 -bar
  ? {c1 eval {info exists :foo}} 1
  ? {c1 eval {info exists :bar}} 1
  ? {c1 eval {info exists :x}} 0
}

#
# check inticmd + noarg (should not be allowed)
#
nx::Test case alias-noarg {
  Class create C {
    :public class method setObjectParams {spec} {
      set :objectparams $spec
      ::nsf::invalidateobjectparameter [current]
    }
    :class method objectparameter {} {
      return ${:objectparams} 
    }
  }
  
  C setObjectParams {initcmd:initcmd,noarg}
  ? {C create c1} {option "noarg" only allowed for parameter type "alias"}
}

#
# check alias + args
#
nx::Test case alias-args {
  Class create C {
    :public class method setObjectParams {spec} {
      set :objectparams $spec
      ::nsf::invalidateobjectparameter [current]
    }
    :class method objectparameter {} {
      return ${:objectparams} 
    }
    :public method Residualargs args {
      puts stderr "aliased RESIDUALARGS <[llength $args]>"
      puts stderr "....... <$args>"
      set :args $args

    }
    :public method residualargs args {
      puts stderr "residualargs <$args>"
    }
  }
  C copy D
  
  # TODO: check the meaning of these
  C setObjectParams {args}
  D setObjectParams {-a args}

  # Configure object parameters to call method Residualargs with
  # option args when args is used
  C setObjectParams {args:alias,method=Residualargs,args}
  D setObjectParams {-a args:alias,method=Residualargs,args}

  # If no residual args are provided, the method residualargs is not
  # called. This is the same rule as for all other consuming object
  # parameter dispatches
  ? {C create c1} {::c1}
  ? {c1 eval {info exists :args}} 0
  ? {D create c1} {::c1}
  ? {c1 eval {info exists :args}} 0

  # Residual args are provided, the method residualargs is
  # called. 
  ? {C create c1 1 2 3} {::c1}
  ? {c1 eval {info exists :args}} 1
  ? {c1 eval {set :args}} {1 2 3}
  ? {D create c1 1 2 3} {::c1}
  ? {c1 eval {info exists :args}} 1
  ? {c1 eval {set :args}} {1 2 3}

  #
  # Provide a default for args.
  #
  C setObjectParams {{args:alias,method=Residualargs,args {hello world}}}

  # use the default
  ? {C create c1} {::c1}
  ? {c1 eval {info exists :args}} 1
  ? {c1 eval {set :args}} {hello world}
  
  # override the default
  ? {C create c1 a b c} {::c1}
  ? {c1 eval {info exists :args}} 1
  ? {c1 eval {set :args}} {a b c}

  #
  # don't allow other types for parameter option "args"
  #
  C setObjectParams {{args:alias,int,method=Residualargs,args {hello world}}}
  ? {C create c1} {Refuse to redefine parameter type of 'args' from type 'integer' to type 'args'}
  ? {c1 eval {info exists :args}} 0
  C setObjectParams {{args:int,alias,method=Residualargs,args {hello world}}}
  ? {C create c1} {Refuse to redefine parameter type of 'args' from type 'integer' to type 'args'}
  ? {c1 eval {info exists :args}} 0

  #
  # don't allow multiplicity settings for parameter option "args"
  #
  C setObjectParams {{args:alias,method=Residualargs,0..n,args {hello world}}}
  ? {C create c1} {Multiplicity settings for variable argument parameter "args" not allowed}
  ? {c1 eval {info exists :args}} 0

  C setObjectParams {args:alias,method=Residualargs,args,1..n}
  ? {C create c1} {Multiplicity settings for variable argument parameter "args" not allowed}
  ? {c1 eval {info exists :args}} 0
  
  #
  # make sure, parameter with parameter option "args" is used in last parameter
  #
  C setObjectParams {a:alias,method=Residualargs,args -b:integer}
  ? {C create c1 hello world} {parameter option "args" invalid for parameter "a"; only allowed for last parameter}
  ? {c1 eval {info exists :args}} 0
}



nx::Test case alias-init {
  Class create C {
    :public class method setObjectParams {spec} {
      set :objectparams $spec
      ::nsf::invalidateobjectparameter [current]
    }
    :class method objectparameter {} {
      return ${:objectparams} 
    }
    :method init {} {
      incr :y
    }
  }

  # call init between -a and -b
  C setObjectParams {-a init:alias,noarg -b:integer}
  ? {C create c1} {::c1}
  # "init" should be called only once
  ? {c1 eval {set :y}} 1
}
#puts stderr ===exit
#exit

#
# check xotcl with residual args
#
nx::Test case xotcl-residualargs {
  package req XOTcl

  ? {::xotcl::Class create XD -set x 1} "::XD"
  #? {c1 eval {info exists :args}} 0
  ? {XD objectparameter} "-mixin:mixinreg,alias,0..n -filter:filterreg,alias,0..n -class:class,alias args:alias,method=residualargs,args"

  #
  # test passing arguments to init
  #
  ::XD instproc init args {
    set :args $args
  }
  
  ::XD create x1 1 2 3 -set x 1
  ? {x1 exists x} 1
  ? {x1 exists args} 1
  ? {x1 set args} {1 2 3}
}


nx::Test parameter count 100000
nx::Test case xotcl-residualargs {

  ::xotcl::Class create XC -parameter {a b c}
  ::XC instproc init args {set :x $args; incr :y}

  ::nx::Class create C {
    :attribute a
    :attribute b
    :attribute c
    :method init args {set :x $args; incr :y}
  }
  
  ? {XC create xc1 -a 1} ::xc1
  ? {XC create xc2 x y -a 1} ::xc2

  ? {C create c1 -a 1} ::c1
  ? {xc2 eval {info exists :a}} 1
  ? {xc2 eval {set :x}} {x y}
  ? {xc2 eval {set :y}} 1
  ? {c1 eval {info exists :a}} 1
  ? {c1 eval {set :y}} 1
}

# TODO: what todo with object parameter inspection for names with alias, forward... "names" do not always correspond with vars set.
#puts stderr ===exit