Version 13 of TclImplForNamedArguments

Updated 2017-03-24 18:11:39 by avl

This is a pure Tcl reference implementation for a variant of TIP 457.

procx name paramspec body creates a command named name like tcl's proc, but allows for an extended syntax to specify the formal arguments.

New Features by March 24th 2017:

  • no more -name ... -value ... -- the problems just didn't show up for the provided solution.
  • {allnkitchensink -names {n name ...} -flags {glob regexp exact} -flagvals {low 0 med 5 high 9} } -- Motivation for having both -flags and -flagvals: sometimes the flag names have a domain-specific meaning and sometimes the flag names are an interface detail not reflected in the body other than by mapping to something else.
  • {pair -list 2}
  • {cmd -name command -list 1 -default {}} -- safely detect unspecified non-required options with [llength $cmd]
  • tip288 semantics now also consider non-default named arguments
  • implementation moved into namespace procx, only import procx into ::
  • "-d" and "-def" as aliases for "-default". -names, -flags and -flagvals also have singular forms as alias.

New Features by March 22nd 2017:

  • -upvar is now supported
  • args and defaulted arguments can now occur at any position within the param-spec. Certain combinations might not be overly useful, though. This now also supports the [lsearch ... haystack needle] interface pattern.
  • no longer needs explicit call-wrapping
  • probably some bugs fixed.

Still missing, but on ToDo List:

  • detect cases compatible with old proc, and skip "call" for these - upvar would be still supported.

Limitations of this pure-Tcl version are: (not likely to be changed)

  • utter lack of introspection
  • ways slower than plain tcl procedure calls.

Example usage:

procx foo {a {b 0} {c -default 0} {d 0 -flagval {d 1}} {e 0}} { list $a -- $b -- $c -- $d -- $e }

foo A
foo A B
foo A B C
foo A B C -d
foo A B C E


procx process {
   {loglvl -default 3
           -name lvl -flagvals {q 0 v 9} }
   {type -default "snafu" -flags {foo bar} }
   args
} { list lvl $loglvl -- type $type -- args $args }

process la la la
process -foo
process -lvl 42
process -v
process -q -- -bar goes in args


procx testrep {{opt -default 42 -name o} val} { tcl::unsupported::representation $val }

testrep [expr {-42}]
testrep -- [expr {-42}]
testrep -o 0 [expr {-42}]
testrep -o 0 -- [expr {-42}]


procx justsick {
   {arg1 -flags {foo bar} -name baz -list 2 -default none }
   {arg2 none}
   {arg3 -flags {foo bar baz} }
   args
   {arg4 -list 2}
} { 
   list $arg1 -- $arg2 -- $arg3 -- $args -- $arg4
}

justsick -baz -baz -baz
justsick -baz -baz -baz -baz
justsick -baz -baz -baz -baz -baz
justsick -baz -baz -baz -baz -baz -baz
justsick -baz -baz -baz -baz -baz -baz -baz
justsick -baz -baz -baz -baz -baz -baz -baz -baz
justsick -baz -baz -baz -baz -baz -baz -baz -baz -baz 
justsick -baz -baz -baz -baz -baz -baz -baz -baz -baz -baz

Implementation:

namespace eval procx {
   proc procx {name params body} {
      set cache {}; set allnames {}; set has_args 0; set upvars {}
      set group_args  [dict create]; # formal argnames with options
      set group_names [dict create]; # option names with description
      set group_minArgs 0          ; # number of required arguments in group
      set total_minArgs 0          ; # total number of required arguments
      
      foreach argspec $params {
         set argspec [lassign $argspec argname]; # extract argname

         if {$argname eq "args"} {
            set has_args 1 ; # will be added to allnames as last one.
            if {[llength $argspec]} { error "no flags or default allowed for `args'" }
            set minArgs 0 ;# args is certainly not "ND"
         } else {
            lappend allnames $argname; # add only non-"args" to list
            # canonicalize argspec:
            if {[llength $argspec] & 1} {
               set argspec [linsert $argspec 0 "-default"]
            }
            set minArgs -1 ;# undecided
         }
         # initialize option container and argspec state:
         set argopts {}; set listlen 0; set defset 0; set upvarset 0; set nameset 0
         # sort out options into option groups:
         foreach {o v} $argspec {
            switch -exact -- $o {
               "-default" - "-def" - "-d" {
                  if {$defset} { error "only one -default option allowed" }
                  dict set argopts "-default" $v; set minArgs 0; set defset 1
               }
               "-list" {
                  if {$listlen} { error "only one -list option allowed" }
                  if {$v <= 0} { error "-list arg must be positive" }
                  set listlen $v
               }
               "-upvar" {
                  if {$upvarset} { error "only one -upvar option allowed" }
                  lappend upvars [list $argname] $v; set upvarset 1
               }
               "-flags" - "-flag" {;# option names are their own values
                  if {[llength $v]} {
                     if {$minArgs!=0} { set minArgs 1 }
                     foreach f $v {
                        if {[dict exists group_names "-$f"]} {
                           error "duplicate option name within group"
                        }; dict set group_names "-$f" [list $argname 1 $f]
                     }; set nameset 1
                  }
               }
               "-flagvals" - "-flagval" {;# option names mapped to values
                  if {[llength $v]} {
                     if {$minArgs!=0} { set minArgs 1 }
                     foreach {f fv} $v {
                        if {[dict exists group_names "-$f"]} {
                           error "duplicate option name within group"
                        }; dict set group_names "-$f" [list $argname 1 $fv]
                     }; set nameset 1
                  }
               }
               "-name" - "-names" {;# option names taking >0 argument(s)
                  if {[llength $v]} {
                     if {$minArgs<0} { set minArgs -2 }
                     foreach f $v {
                        if {[dict exists group_names "-$f"]} {
                           error "duplicate option name within group"
                        }; dict set group_names "-$f" [list $argname 0 {}]
                     }; set nameset 1
                  }
               }
               default { error "unknown option \"$o\" in argspec for \"$argname\"" }
            }
         }
         # minArgs: 0: has default; 1: has flags; -2: just name; -1: positional
         # listlen: 0: no enlisting (1 arg); <n>: enlist <n> arguments
         # if just name: minArgs = $listlen+1; if positional: minArgs = $listlen
         if {$minArgs < 0} { set minArgs [expr {max($listlen,1) - ($minArgs+1)}] }
         # save information for call-wrapper
         dict set argopts "-list" $listlen; dict set argopts "minArgs" $minArgs
         
         incr total_minArgs $minArgs
         if {$nameset} {;# named argument: add to group
            dict set group_args $argname $argopts
            incr group_minArgs $minArgs
         } else {;# positional argument
            # eventually finish group of named arguments
            if {[dict size $group_args]>0} {;# flush
               lappend cache $group_args $group_names $group_minArgs
               set group_args [dict create]
               set group_names [dict create]
               set group_minArgs 0
            }
            # add this positional argument to the cache
            lappend cache [list $argname $argopts] [dict create] $minArgs
         }
      }
      # eventually finish remaining group of named arguments
      if {[dict size $group_names]>0} {;# flush
         lappend cache $group_args $group_names $group_minArgs
      }

      if {[llength $upvars]} {
         # inject the upvars into the body
         set templ0 { [set %s][unset %s] %s}
         set templ1 { [set %s [set %s]][unset %s] %s}
         set intro "upvar 1"
         foreach {la an} $upvars {
            if {$an eq ""} {
               append intro [format $templ0 $la $la $la]
            } else {
               append intro [format $templ1 [list $an] $la $la $la]
            }
         }
         set body "$intro;$body"
      }

      set intname "cache::$name"
      set cache::data($intname) [list $total_minArgs $allnames $cache]
      #debug Cache: $intname -- $cache::data($intname)
      if {$has_args} { lappend allnames "args" }
      uplevel 1 [list interp alias {} $name {} ::procx::call $intname]
      proc $intname $allnames $body
   }
   proc call {name args} {
      set argnr 0; set formargs [dict create "args" {}]
      lassign $cache::data($name) total_minArg allnames cache
      set nargs [expr {[llength $args]-$total_minArg}]
      #debug llengh [llength $args] -- tmin $total_minArg -- nargs $nargs 
      if {$nargs < 0} { error "too few arguments" }

      foreach {argopts nameopts minArgs} $cache {
         set arg [lindex $args $argnr]; set isnamed [dict size $nameopts]
         #debug group [dict keys $argopts] -- arg $arg -- [expr {$isnamed?"isnamed":""}]

         if {$isnamed} {; # assign value to named argument
            set horizon [expr {$nargs + $minArgs}]
            #debug argnr $argnr -- min $minArgs -- horiz $horizon -- nargs $nargs
            while { $argnr < $horizon && $arg ne "--" && [dict exists $nameopts $arg] } {
               lassign [dict get $nameopts $arg] argname isflag flagval
               set opts [dict get $argopts $argname]
               set minArgs [dict get $opts "minArgs"]
               set listlen [dict get $opts "-list"]
               
               # Aspects to consider:
               # A)  a) flag   b) name w/o list  c) name with list
               #  -> number of values it would consume, if accepted
               set wanted [expr {$isflag ? 1 : max(1,$listlen) }]
               # B)  arg has  a) def  b) flags  c) only name
               #       and: is the formal arg already set
               #  -> number of values reserved for this option
               set reserved [expr {[dict exists $formargs $argname] ? 0 : $minArgs } ]

               if {$argnr+$wanted > $nargs+$reserved} {
                  #debug not taken -- $argnr+$wanted>$nargs+$reserved
                  break; # cannot use this option for this group!
               }

               incr nargs $reserved; 
               if {$isflag} {
                  dict set formargs $argname $flagval
               } elseif {$listlen} {
                  set argto [expr {$argnr+$listlen-1}]
                  dict set formargs $argname [lrange $args $argnr $argto]
                  set argnr $argto
               } else {
                  dict set formargs $argname [lindex $args [incr argnr]]
               }; incr argnr; set arg [lindex $args $argnr]
            }
            # no more args available for this group
            if {$argnr < $nargs && $arg eq "--"} { incr argnr }
            # now try to complete the group with defaults
            dict for {n opts} $argopts {; # check if all have value or default
               if {![dict exists $formargs $n]} {
                  if {[dict exists $opts "-default"]} {
                     dict set formargs $n [dict get $opts "-default"]
                  } else { 
                     #puts "formargs: [dict get $formargs]"
                     error "formal argument $n has not been given a value"
                  }
               }
               #debug $n = [dict get $formargs $n]
            }
         } else {
            lassign $argopts argname opts
            #debug argnr $argnr -- min $minArgs -- nargs $nargs
            if {$argname eq "args"} {
               set argto [expr {$nargs-1}]
               dict set formargs "args" [lrange $args $argnr $argto]
               set argnr $nargs
            } else {
               set listlen [dict get $opts "-list"]; set useargs [expr {max(1,$listlen)}]
               # for positional arguments, minArgs equals either 0 or $useargs
               if {$minArgs || $argnr+$useargs <= $nargs} {;# fits
                  incr nargs $minArgs; # $minArgs values are already reserved.
                  if {$listlen} {
                     set argto [expr {$argnr+$listlen-1}]
                     dict set formargs $argname [lrange $args $argnr $argto]
                     set argnr $argto
                  } else {
                     dict set formargs $argname $arg
                  }; incr argnr; set arg [lindex $args $argnr]
               } else {;# doesn't fit => use default (not list'ed!)
                  dict set formargs $argname [dict get $opts "-default"]
               }
            }
            #debug $argname = [dict get $formargs $argname]
         }
      }
      if {$argnr < [llength $args]} {
         error "too many arguments"
      }
      set args [lmap x $allnames {dict get $formargs $x}]
      lappend args {*}[dict get $formargs "args"]
      tailcall $name {*}$args
   }
   #proc debug {args} { puts "Debug: $args" }
   namespace eval cache {}
   namespace export procx 
}
namespace import procx::procx