package require XOTcl
namespace import -force xotcl::*
package require xotcl::test

proc ? {cmd expected {msg ""}} {
  set count 10
  if {$msg ne ""} {
    set t [Test new -cmd $cmd -count $count -msg $msg]
  } else {
    set t [Test new -cmd $cmd -count $count]
  }
  $t expected $expected 
  $t run
}

catch {::xotcl::configure cacheinterface true}
set mkTypeChecker 0

puts stderr =====START
Class C -parameter {a {b:boolean} {c 1}}

C c1 
? {C objectparameter} "-instfilter:relation -superclass:relation -instmixin:relation\
-mixin:relation -filter:relation -class:relation args"

if {$mkTypeChecker} {
  set e {-a {-b:boolean,initcmd {
if {[::xotcl::my exists b]} {::xotcl::my set __oldvalue(b) [::xotcl::my set b]}
::xotcl::my trace add variable b write  [list ::C::slot::b __value_changed_cmd [::xotcl::self] {
::xotcl::my check_single_value [$obj set b]  {[::C::slot::b type=boolean b $value]} boolean $obj b}]}} {-c 1} -mixin:relation -filter:relation -class:relation args}
} else {
  set e {-a -b:boolean {-c 1} -mixin:relation -filter:relation -class:relation args}
}
? {c1 objectparameter} $e

# reclass to Object, no neet to do anything on caching
puts stderr "=== reclass c1 to Object"
c1 class Object
? {c1 objectparameter} "-mixin:relation -filter:relation -class:relation args"

puts stderr "=== create Class D"
Class D -superclass C -parameter {d:required}
D d1 -d 100

if {$mkTypeChecker} {
  set e {-d:required -a {-b:boolean,initcmd {
if {[::xotcl::my exists b]} {::xotcl::my set __oldvalue(b) [::xotcl::my set b]}
::xotcl::my trace add variable b write  [list ::C::slot::b __value_changed_cmd [::xotcl::self] {
::xotcl::my check_single_value [$obj set b]  {[::C::slot::b type=boolean b $value]} boolean $obj b}]}} {-c 1} -mixin:relation -filter:relation -class:relation args}
} else {
  set e {-d:required -a -b:boolean {-c 1} -mixin:relation -filter:relation -class:relation args}
}
? {d1 objectparameter} $e

set case "instmixin M into D"
Class M -parameter {m1 m2 b}
Class M2 -parameter {b2}
puts stderr "=== $case"
D instmixin M
? {d1 objectparameter} "-b -m1 -m2 -d:required -a {-c 1} -mixin:relation -filter:relation -class:relation args" "$case: mixin added"
M instmixin M2
? {d1 objectparameter} "-b2 -b -m1 -m2 -d:required -a {-c 1} -mixin:relation -filter:relation -class:relation args" "$case: transitive mixin added"
D instmixin ""
#we should have again the old interface

if {$mkTypeChecker} {
  set e {-d:required -a {-b:boolean,initcmd {
if {[::xotcl::my exists b]} {::xotcl::my set __oldvalue(b) [::xotcl::my set b]}
::xotcl::my trace add variable b write  [list ::C::slot::b __value_changed_cmd [::xotcl::self] {
::xotcl::my check_single_value [$obj set b]  {[::C::slot::b type=boolean b $value]} boolean $obj b}]}} {-c 1} -mixin:relation -filter:relation -class:relation args}
} else {
  set e {-d:required -a -b:boolean {-c 1} -mixin:relation -filter:relation -class:relation args}
}

? {d1 objectparameter} $e

set case "instmixin M into C"
puts stderr "=== $case"
C instmixin M
? {d1 objectparameter} "-b2 -b -m1 -m2 -d:required -a {-c 1} -mixin:relation -filter:relation -class:relation args" "$case: mixin added"
C instmixin ""
#we should have again the old interface

if {$mkTypeChecker} {
  set e {-d:required -a {-b:boolean,initcmd {
if {[::xotcl::my exists b]} {::xotcl::my set __oldvalue(b) [::xotcl::my set b]}
::xotcl::my trace add variable b write  [list ::C::slot::b __value_changed_cmd [::xotcl::self] {
::xotcl::my check_single_value [$obj set b]  {[::C::slot::b type=boolean b $value]} boolean $obj b}]}} {-c 1} -mixin:relation -filter:relation -class:relation args}
} else {
  set e {-d:required -a -b:boolean {-c 1} -mixin:relation -filter:relation -class:relation args}
}

? {d1 objectparameter} $e

# test 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"
catch {D create d1} errorMsg
? {set _ $errorMsg} "::d1 configure: required argument 'd' is missing" "check error msg"

? {if {[catch {D create d2 -d x -b a} errorMsg]} {set errorMsg}} \
    {expected boolean value but got "a"} \
    "create d2 without required argument given"

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

? {if {[catch {d1 foo} errorMsg]} {set errorMsg}} \
    {::d1 foo: required argument 'r' is missing} \
    "call method without a required argument"

? {if {[catch {d1 foo -r a} errorMsg]} {set errorMsg}} \
    {expected integer but got "a"} \
    "required argument is not integer"

? {if {[catch {d1 foo -r 1} errorMsg]} {set errorMsg}} \
    {expected integer but got "aaa"} \
    "default value is not of type integer"

? {if {[catch {d1 foo -r 1 -x 1 -object d1} errorMsg]} {set errorMsg}} \
    "" \
    "pass object"

? {if {[catch {d1 foo -r 1 -x 1 -object d11} errorMsg]} {set errorMsg}} \
    {Invalid argument: cannot convert 'd11' to object} \
    "pass non-existing object"

? {if {[catch {d1 foo -r 1 -x 1 -class D} errorMsg]} {set errorMsg}} \
    "" \
    "pass class"

? {if {[catch {d1 foo -r 1 -x 1 -class d1} errorMsg]} {set errorMsg}} \
    {Invalid argument: cannot convert 'd1' to class} \
    "pass object instead of class"

? {if {[catch {d1 foo -r 1 -x 1 -class D11} errorMsg]} {set errorMsg}} \
    {Invalid argument: cannot convert 'D11' to class} \
    "pass non-existing class"

? {if {[catch {D instproc foo {a:relation} {}} errorMsg]} {set errorMsg}} \
    {Parameter option 'relation' not allowed} \
    "don't allow relation option as method parameter"

# non required positional arguments
D instproc 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 instproc 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"

#
#
# subst default tests
#
D instproc 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 on method"  

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

? {subst {[bar1 s]-[bar1 literal]-[bar1 c]-[bar1 d]}} \
    {::bar1-[self]-::Bar-$d} \
    "substdefault on object"  

# 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 instproc 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 instargs bar} {x y z} "query old instargs" 
? {D info instparams bar} \
    {{-s:substdefault {[self]}} {-literal {[self]}} {-c:substdefault {[my c]}} {-d:integer,substdefault {$d}} {-switch:switch 0} -optflag x y:integer {z 1}} \
    "query instparams" 

D instproc foo {a b {-c 1} {-d} x {-end 100}} {
  set result [list]
  foreach v [[self class] info instparams [self proc] -varNames] {
    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 instproc foo {a b c {end 100}} {
  set result [list]
  foreach v [[self class] info instparams [self proc] -varNames] {
    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"

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

? {Class info instparams instproc} \
    "name args body precondition:optional postcondition:optional" \
    "query instparams for C-defined 'instproc' method"

? {Object info instparams forward} \
    "method -default -earlybinding -methodprefix -objscope -onerror -verbose target:optional args" \
    "query instparams for C-defined 'forward' method"

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

::xotcl::parameterType proc type=mytype {name value} {
  if {$value < 1 || $value > 3} {
    error "Value '$value' of parameter $name is not between 1 and 3"
  }
}

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

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

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

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

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

puts stderr =====END