package require XOTcl
package require xotcl::test

Test parameter count 10

catch {::xotcl::configure cacheinterface true}

::xotcl::use xotcl2

#######################################################
# valuecheck
#######################################################
Test case valuecheck
Test parameter count 10000
#Test parameter count 10
Object create o1
? {::xotcl::valuecheck object o1} 1
? {::xotcl::is o1 object} 1
? {::xotcl::valuecheck class o1} 0
? {::xotcl::valuecheck class Test} 1
? {::xotcl::valuecheck object,multivalued [list o1 Test]} 1
? {::xotcl::valuecheck integer 1} 1
? {::xotcl::valuecheck integer,multivalued [list 1 2 3]} 1
? {::xotcl::valuecheck integer,multivalued [list 1 2 3 a]} 0
? {::xotcl::valuecheck in1 aaa} {invalid value constraints "in1"}

#
# parameter options
#   required
#   optional
#   multivalued
#   noarg
#   arg=
#
#   substdefault:  if no value given, subst on default (result is substituted value); for scripted/c methods/obj parm
#   initcmd:       evaluate body in an xotcl nonleaf frame, called via configure 
#                  (example: last arg on create)
#   method         call specified method in an xotcl nonleaf frame, called via configure;
#                  specified value is the first argument unless "noarg" is used  
#                  (example: -noinit).
#
# parameter type   multivalued  required  noarg   arg=  valueCheck  methodParm   objectParm
#  substdefault       NO         NO         NO    NO      NO           YES         YES (autmatically set by -parameter on []}
#  initcmd            NO         YES        NO    NO      NO        NO/POSSIBLE    YES
#  method             NO         YES        YES   YES     NO        NO/POSSIBLE    YES
#
#  relation           NO         YES        NO    YES     NO           NO          YES
#
#  switch             NO         NO         NO    NO      NO           YES         YES
#  integer            YES        YES        NO    NO      YES          YES         YES    
#  boolean            YES        YES        NO    NO      YES          YES         YES
#  object             YES        YES        NO    NO      YES          YES         YES
#  class              YES        YES        NO    NO      YES          YES         YES
#  userdefined        YES        YES        NO    YES     YES          YES         YES

#######################################################
# objectparameter
#######################################################
Test case objectparameter

Test parameter count 10
Class create C -parameter {a {b:boolean} {c 1}}
C create c1 
? {C eval {:objectparameter}} "-object-mixin:relation -mixin:relation,arg=class-mixin\
-superclass:relation -object-filter:relation -filter:relation,arg=filter-mixin\
-class:relation -parameter:method,optional -noinit:method,optional,noarg\
-volatile:method,optional,noarg arg:initcmd,optional"

? {c1 eval {:objectparameter}} \
    "-a -b:boolean {-c 1} -mixin:relation,arg=object-mixin -filter:relation\
-class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\
arg:initcmd,optional"

#######################################################
# reclass to Object, no need to do anything on caching
#######################################################
Test case reclass
c1 class Object
? {c1 eval :objectparameter} "-mixin:relation,arg=object-mixin -filter:relation\
-class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\
arg:initcmd,optional"

Class create D -superclass C -parameter {d:required}
D create d1 -d 100

? {d1 eval :objectparameter} \
    "-d:required -a -b:boolean {-c 1} -mixin:relation,arg=object-mixin -filter:relation\
-class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\
arg:initcmd,optional"

#######################################################
# Add mixin
#######################################################
Test case objparam-mixins
Class create M -parameter {m1 m2 b}
Class create M2 -parameter {b2}
D mixin M
? {d1 eval :objectparameter} \
    "-b -m1 -m2 -d:required -a {-c 1} -mixin:relation,arg=object-mixin -filter:relation\
-class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\
arg:initcmd,optional" \
    "mixin added"
M mixin M2
? {d1 eval :objectparameter} \
    "-b2 -b -m1 -m2 -d:required -a {-c 1} -mixin:relation,arg=object-mixin -filter:relation\
-class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\
arg:initcmd,optional" \
    "transitive mixin added"
D mixin ""
#we should have again the old interface

? {d1 eval :objectparameter} \
    "-d:required -a -b:boolean {-c 1} -mixin:relation,arg=object-mixin -filter:relation\
-class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\
arg:initcmd,optional"

C mixin M
? {d1 eval :objectparameter} \
    "-b2 -b -m1 -m2 -d:required -a {-c 1} -mixin:relation,arg=object-mixin -filter:relation\
-class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\
arg:initcmd,optional" \
    "mixin added"
C mixin ""
#we should have again the old interface


? {d1 eval :objectparameter} \
    "-d:required -a -b:boolean {-c 1} -mixin:relation,arg=object-mixin -filter:relation\
-class:relation -noinit:method,optional,noarg -volatile:method,optional,noarg\
arg:initcmd,optional"


#######################################################
# test passed arguments
#######################################################
Test case passed-arguments

? {catch {D create d1 -d 123}} 0 "create d1 with required argument given"
? {catch {D create d1}} 1 "create d1 without required argument given"
? {D create d1} "::d1 configure: required argument 'd' is missing" "check error msg"

? {D create d2 -d x -b a} \
    {expected boolean value but got "a"} \
    "create d2 without required argument given"

D create d1 -d 1
D method foo {-b:boolean -r:required,int {-x:int aaa} {-object:object} {-class:class}} {
  #if {[info exists x]} {puts stderr x=$x}
}

? {d1 foo} \
    "::d1 foo: required argument 'r' is missing" \
    "call method without a required argument"

? {d1 foo -r a} \
    {expected integer but got "a"} \
    "required argument is not integer"

? {d1 foo -r 1} \
    {expected integer but got "aaa"} \
    "default value is not of type integer"

? {d1 foo -r 1 -x 1 -object d1} \
    "" \
    "pass object"

? {d1 foo -r 1 -x 1 -object d11} \
    {expected object but got "d11"} \
    "pass non-existing object"

? {d1 foo -r 1 -x 1 -class D} \
    "" \
    "pass class"

? {d1 foo -r 1 -x 1 -class d1} \
    {expected class but got "d1"} \
    "pass object instead of class"

? {d1 foo -r 1 -x 1 -class D11} \
    {expected class but got "D11"} \
    "pass non-existing class"

? {D method foo {a:relation} {}} \
    {Parameter option 'relation' not allowed} \
    "don't allow relation option as method parameter"

#######################################################
# non required positional arguments
#######################################################
Test case non-reg-args

D method foo {a b:optional c:optional} {
  return "[info exists a]-[info exists b]-[info exists c]"
}
? {d1 foo 1 2} "1-1-0" "omit optional argument"
? {d1 foo 1} "1-0-0" "omit optional arguments"

# non required positional arguments and args
D method foo {a b:optional c:optional args} {
  return "[info exists a]-[info exists b]-[info exists c]-[info exists args]"
}
? {d1 foo 1 2} "1-1-0-1" "omit optional argument"
? {d1 foo 1} "1-0-0-1" "omit optional arguments"

#######################################################
# non required positional arguments
#######################################################
Test case multivalued
Object create o

D method foo {m:integer,multivalued} {
  return $m
}
? {d1 foo ""} "" "emtpy list"
? {d1 foo 1} "1" "single value"
? {d1 foo {1 2}} "1 2" "multiple values"
? {d1 foo {1 a 2}} \
    {invalid value in "1 a 2": expected integer but got "a"} \
    "multiple values with wrong value"

D method foo {m:object,multivalued} {
  return $m
}
? {d1 foo ""} "" "emtpy list"
? {d1 foo o} "o" "single value"
? {d1 foo {o d1 x}} \
    {invalid value in "o d1 x": expected object but got "x"} \
    "multiple values"

Class create Foo -parameter {
  {ints:integer,multivalued}
}
? {Foo create foo -ints {1 2}} "::foo"
? {Foo create foo -ints {1 a 2}} {invalid value in "1 a 2": expected integer but got "a"}

Foo create foo -ints {1 2}
? {foo ints add 0} "0 1 2"
? {foo ints add a} {expected integer but got "a"}

#######################################################
# subst default tests
#######################################################
Test case subst-default

D method bar {
  {-s:substdefault "[self]"} 
  {-literal "[self]"} 
  {-c:substdefault "[my c]"} 
  {-d:integer,substdefault "$d"}
} {
  return $s-$literal-$c-$d
}

? {d1 bar -c 1} {::d1-[self]-1-1} "substdefault in method parameter"

Class create Bar -superclass D -parameter {
  {s "[self]"} 
  {literal "\\[self\\]"} 
  {c "[my info class]"} 
  {d "literal $d"}
  {switch:switch}
}
Bar create bar1
#puts stderr [bar1 objectparameter]

? {subst {[bar1 s]-[bar1 literal]-[bar1 c]-[bar1 d]-[bar1 switch]}} \
    {::bar1-[self]-::Bar-literal $d-0} \
    "substdefault and switch in object parameter 1"

Bar create bar2 -switch
? {subst {[bar2 s]-[bar2 literal]-[bar2 c]-[bar2 d]-[bar2 switch]}} \
    {::bar2-[self]-::Bar-literal $d-1} \
    "substdefault and switch in object parameter 2"

# Observations:
#  1) syntax for "-parameter" and method parameter is quite different.
#     it would be nice to be able to specify the objparameters in
#     the same syntax as the method parameters. 
#
# 1a) Especially specifying "-" in front of a -parameter or not might
#     be confusing.
#
# 1b) Positional args for obj parameter and arguments for init
#     might be confusing as well. Should we forget about 
#     passing arguments to init?
#
#  2) substdefault for '$' in -parameter defaults does not make much sense.
#     deactivated for now; otherwise we would need "\\"

D method bar {
  {-s:substdefault "[self]"} 
  {-literal "[self]"} 
  {-c:substdefault "[my c]"} 
  {-d:integer,substdefault "$d"}
  {-switch:switch}
  {-optflag}
  x
  y:integer
  {z 1}
} {
  return $s-$literal-$c-$d
}

? {D info method args bar} {s literal c d switch optflag x y z} "all args" 
? {D info method parameter bar} \
    {{-s:substdefault {[self]}} {-literal {[self]}} {-c:substdefault {[my c]}} {-d:integer,substdefault {$d}} {-switch:switch 0} -optflag x y:integer {z 1}} \
    "query method parameter" 

D method foo {a b {-c 1} {-d} x {-end 100}} {
  set result [list]
  foreach v [[self class] info method args [self proc]] {
    lappend result $v [info exists $v]
  }
  return $result
}
? {d1 foo 1 2 3} \
    "a 1 b 1 c 1 d 0 x 1 end 1" \
    "parse multiple groups of nonpos args"

D method foo {a b c {end 100}} {
  set result [list]
  foreach v [[self class] info method args [self proc]] {
    lappend result $v [info exists $v]
  }
  return $result
}
? {d1 foo 1 2 3} \
    "a 1 b 1 c 1 end 1" \
    "query arguments with default, no paramdefs needed"

#######################################################
# Query method parameter
#######################################################
Test case query-method-parameter

? {D info method parameter foo} \
    "a b c {end 100}" \
    "query instparams with default, no paramdefs needed"

? {Class info method parameter method} \
    "name arguments body -precondition -postcondition" \
    "query instparams for scripted method 'method'"

? {catch {Object info method parameter forward}} \
    "1" \
    "query parameter for C-defined method 'forward'"

? {Object info method parameter autoname} \
    "-instance -reset name" \
    "query parameter for C-defined method 'autoname'"

# TODO: how to query the params/instparams of info subcommands?
#? {::xotcl::objectInfo info params params} \
#    "xxx" \
#    "query instparams for info method 'params' method"


#######################################################
# user defined parameter types
#######################################################
Test case user-types

#
# create class and object for nonpositional argument processing
Class create ::xotcl::ParameterType
foreach cmd [info command ::xotcl::cmd::ParameterType::*] {
  ::xotcl::alias ::xotcl::ParameterType [namespace tail $cmd] $cmd
}
# create an object for dispatching
::xotcl::ParameterType create ::xotcl::parameterType

# create a userdefined type
::xotcl::parameterType method type=mytype {name value args} {
  if {$value < 1 || $value > 3} {
    error "Value '$value' of parameter $name is not between 1 and 3"
  }
}

D method foo {a:mytype} {
  puts stderr a=$a
}
d1 foo 1

? {d1 foo 10} \
    "Value '10' of parameter a is not between 1 and 3" \
    "invalid value"

D method foo {a:unknowntype} {
  puts stderr a=$a
}

? {d1 foo 10} \
    "::xotcl::parameterType: unable to dispatch method 'type=unknowntype'" \
    "missing type checker"

# create a userdefined type with a simple argument
::xotcl::parameterType method type=in {name value arg} {
  if {$value ni [split $arg |]} {
    error "Value '$value' of parameter $name not in permissible values $arg"
  }
}

D method foo {a:in,arg=a|b|c} {
  return a=$a
}

? {d1 foo a} "a=a"
? {d1 foo 10} \
    "Value '10' of parameter a not in permissible values a|b|c" \
    "invalid value"

D method foo {a:in,arg=a|b|c b:in,arg=good|bad {-c:in,arg=a|b a}} {
  return a=$a,b=$b,c=$c
}

? {d1 foo a good -c b} "a=a,b=good,c=b"
? {d1 foo a good} "a=a,b=good,c=a"
? {d1 foo b "very good"} \
    "Value 'very good' of parameter b not in permissible values good|bad" \
    "invalid value (not included)"

::xotcl::parameterType method type=range {name value arg} {
  foreach {min max} [split $arg -] break
  if {$value < $min || $value > $max} {
    error "Value '$value' of parameter $name not between $min and $max"
  }
}

D method foo {a:range,arg=1-3 {-b:range,arg=2-6 3} c:range,arg=5-10} {
  return a=$a,b=$b,c=$c
}

? {d1 foo 2 -b 4 9} "a=2,b=4,c=9"
? {d1 foo 2 10} "a=2,b=3,c=10"
? {d1 foo 2 11} \
    "Value '11' of parameter c not between 5 and 10" \
    "invalid value"

# define type twice
? {D method foo {a:int,range,arg=1-3} {return a=$a}} \
    "Refuse to redefine parameter converter to use usertype" \
    "invalid value"

#
# handling of arg with spaces/arg as list
#
::xotcl::parameterType method type=list {name value arg} {
  #puts $value/$arg
}

# handling spaces in "arg" is not not particular nice
D method foo {{"-a:list,arg=2 6" 3} {"b:list,arg=5 10"}} {
  return a=$a,b=$b
}
? {d1 foo -a 2 10} "a=2,b=10"


#######################################################
# testing object types in method parameters
#######################################################
Test case mp-object-types
Class create M
D create d1 -d 1
C create c1 -mixin M
Object create o

# ::xotcl::is supports predicates for objects
#
#   ::xotcl::is <obj> object
#   ::xotcl::is <obj> type <class> 
#   ::xotcl::is <obj> class
#   ::xotcl::is <obj> baseclass
#   ::xotcl::is <obj> metaclass
#   ::xotcl::is <obj> mixin <class>
#
# Map these to type checkers. "object" and "class"
# are already predefined, define the rest.
# TODO: should go finally to predefined.
 
::xotcl::parameterType method type=type {name value arg} {
  if {![::xotcl::is $value type $arg]} {
    error "Value '$value' of $name of not of type $arg"
  }
}
::xotcl::parameterType method type=mixin {name value arg} {
  if {![::xotcl::is $value mixin $arg]} {
    error "Value '$value' of $name has not mixin $arg"
  }
}
::xotcl::parameterType method type=baseclass {name value} {
  if {![::xotcl::is $value baseclass]} {
    error "Value '$value' of $name is not a baseclass"
  }
}
::xotcl::parameterType method type=metaclass {name value} {
  if {![::xotcl::is $value metaclass]} {
    error "Value '$value' of $name is not a metaclass"
  }
}

D method foo-base   {x:baseclass} {return $x}
D method foo-class  {x:class} {return $x}
D method foo-object {x:object} {return $x}
D method foo-meta   {x:metaclass} {return $x}
D method foo-mixin  {x:mixin,arg=::M} {return $x}
D method foo-type   {x:type,arg=::C} {return $x}

? {d1 foo-base ::xotcl2::Object} "::xotcl2::Object"
? {d1 foo-base C} \
    "Value 'C' of x is not a baseclass" \
    "not a base class"

? {d1 foo-class D} "D"
? {d1 foo-class xxx} \
    {expected class but got "xxx"} \
    "not a class"
? {d1 foo-class o} \
    {expected class but got "o"} \
    "not a class"

? {d1 foo-meta ::xotcl2::Class} "::xotcl2::Class"
? {d1 foo-meta ::xotcl2::Object} \
    "Value '::xotcl2::Object' of x is not a metaclass" \
    "not a base class"

? {d1 foo-mixin c1} "c1"
? {d1 foo-mixin o} \
    "Value 'o' of x has not mixin ::M" \
    "does not have mixin M"

? {d1 foo-object o} "o"
? {d1 foo-object xxx} \
    {expected object but got "xxx"} \
    "not an object"

? {d1 foo-type d1} "d1"
? {d1 foo-type c1} "c1"
? {d1 foo-type o} \
    "Value 'o' of x of not of type ::C" \
    "o not of type ::C"


#######################################################
# testing object types in object parameters
#######################################################
Test case op-object-types
Class create M
D create d1 -d 1
C create c1 -mixin M
Object create o

Class create ParamTest -parameter {
  o:object
  c:class
  d:type,arg=D
  m:metaclass
  mix:mixin,arg=M
  b:baseclass
}
? {ParamTest create p -o o} ::p
? {ParamTest create p -o xxx} \
    {expected object but got "xxx"} \
    "not an object"

? {ParamTest create p -mix c1} ::p
? {ParamTest create p -mix o} \
    "Value 'o' of mix has not mixin M" \
    "does not have mixin M"

# TODO: naming "type" and "mixin" not perfect.
#       maybe "type" => "hastype"
#       maybe "mixin" => "hasmixin"
#       => effects as well ::xotcl::is
#
# TODO (optimization): optimizer can improve parameter checking:
#       (a) simple approach: make scripted setter methods on domain
#       (b) maybe nicer: provide arguments to c-setter to 
#           pass parameter definition
#
# TODO: error messages for failed conversions are not consistent
#       should happen, when all kind of parameters finally settled
# 
? {p o o} \
    "o" \
    "value is an object"
? {p o xxx} \
    {expected object but got "xxx"} \
    "value is not an object"

ParamTest slots {
  ::xotcl::Attribute create os -type object -multivalued true
}

? {p os o} \
    "o" \
    "value is a list of objects (1 element)"
? {p os {o c1 d1}} \
    "o c1 d1" \
    "value is a list of objects (multiple elements)"

? {p os {o xxx d1}} \
    {invalid value in "o xxx d1": expected object but got "xxx"} \
    "list with invalid object"

## TODO regression test for type checking, parameter options (initcmd,
## substdefault, combinations with defaults, ...), etc.
puts stderr =====END