Browse Source

pdict and textblock::periodic fixes

master
Julian Noble 5 months ago
parent
commit
f789788169
  1. 20
      src/modules/punk/ansi-999999.0a1.0.tm
  2. 1
      src/modules/punk/args-999999.0a1.0.tm
  3. 13
      src/modules/punk/experiment-999999.0a1.0.tm
  4. 68
      src/modules/punk/lib-999999.0a1.0.tm
  5. 229
      src/modules/textblock-999999.0a1.0.tm

20
src/modules/punk/ansi-999999.0a1.0.tm

@ -1489,7 +1489,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
lappend clist "[a+ {*}$fc {*}$fg Term$i][format %3s $i]"
}
set t [textblock::list_as_table 36 $clist -return object]
set t [textblock::list_as_table -columns 36 -return tableobject $clist]
$t configure -show_hseps 0
#return [$t print]
return $t
@ -1878,7 +1878,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
$t destroy
}
#set displaytable [textblock::class::table new]
set displaytable [textblock::list_as_table 3 $grouptables -return object]
set displaytable [textblock::list_as_table -columns 3 -return tableobject $grouptables]
$displaytable configure -show_header 0 -show_vseps 0
#return $displaytable
set result [$displaytable print]
@ -1946,7 +1946,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu
$t destroy
# -- --- ---
set displaytable [textblock::list_as_table 2 $comparetables -return object]
set displaytable [textblock::list_as_table -columns 2 -return tableobject $comparetables]
$displaytable configure -show_header 0 -show_vseps 0
if {[tcl::dict::get $opts -return] eq "string"} {
@ -4218,9 +4218,21 @@ tcl::namespace::eval punk::ansi::ta {
#*** !doctools
#[call [fun detect] [arg text]]
#[para]Return a boolean indicating whether Ansi codes were detected in text
#[para]
#[para]Important caveat:
#[para] When text is a tcl list made from splitting (or lappending) some ansi string - individual elements may be braced or have certain chars escaped. (one example is if a list element contains an unbalanced brace)
#[para] This can cause square brackets that form part of the ansi being backslash escaped - and the regexp can fail to match
regexp <re> $text
}]
#can be used on dicts - but will check keys too. keys could also contain ansi and have escapes
proc detect_in_list {list} {
foreach item $list {
if {[detect $item]} {
return 1
}
}
return 0
}
proc detect_g0 {text} [string map [list <re> [list $re_g0_group]] {
regexp <re> $text
}]

1
src/modules/punk/args-999999.0a1.0.tm

@ -1177,6 +1177,7 @@ tcl::namespace::eval punk::args {
if {!$is_allow_ansi} {
#allow_ansi 0
package require punk::ansi
#do not run ta::detect on a list
foreach e $vlist {
if {[punk::ansi::ta::detect $e]} {
error "Option $argname for [Get_caller] contains ansi - but -allow_ansi is false. Received: '$e'"

13
src/modules/punk/experiment-999999.0a1.0.tm

@ -435,6 +435,19 @@ namespace eval punk::experiment {
return $result
}
set testblock "a\{\nb"
proc testjoin {{block1 "---\n---"}} {
variable testblock
textblock::join $block1 [a+ red]$testblock
}
proc testjoin2 {} {
set b1 [textblock::join ---\n--- "[a+ red]a\nb"]
set b2 [textblock::join ---\n--- "[a+ red]a\{\nb"]
set result $b1\n$b2
}
#timings indistinguishable
proc map_var {n str} {
set map [list a AA b B c CC d D e EE f F g GG h H i II j J k KK l L m MM]

68
src/modules/punk/lib-999999.0a1.0.tm

@ -397,10 +397,12 @@ namespace eval punk::lib {
proc pdict {args} {
set argd [punk::args::get_dict {
*proc -name pdict -help {Print dict keys,values to channel
(see also showdict)}
*opts -any 1
#default separator to provide similarity to tcl's parray function
-separator -default " = "
-channel -default stdout
-channel -default stdout -help "existing channel - or 'none' to return as string"
*values -min 1 -max -1
dictvar -type string -help "name of dict variable"
patterns -type string -default * -multiple 1
@ -415,21 +417,28 @@ namespace eval punk::lib {
set argd [punk::args::get_dict {
*id punk::lib::pdict
*proc -name punk::lib::pdict -help "display dictionary keys and values"
-channel -default none
-trimright -default 1 -type boolean -help "trim whitespace off rhs of each line
This can help prevent a single long line that wraps in terminal from making every line wrap due to long rhs padding
#todo - table tableobject
-return -default "tailtohead" -choices {tailtohead sidebyside}
-channel -default none
-trimright -default 1 -type boolean -help "Trim whitespace off rhs of each line.
This can help prevent a single long line that wraps in terminal from making every line wrap due to long rhs padding
"
-separator -default " " -help "Separator column between keys and values"
-keysorttype -default "none" -choices {none dictionary ascii integer real}
-keysortdirection -default ascending -choices {ascending descending}
-separator -default " " -help "Separator column between keys and values"
-ansibase_keys -default ""
-ansibase_values -default ""
-keysorttype -default "none" -choices {none dictionary ascii integer real}
-keysortdirection -default ascending -choices {ascending descending}
*values -min 1 -max -1
dictvalue -type dict -help "dict value"
patterns -type string -default * -multiple 1 -help "key or key glob pattern"
dictvalue -type dict -help "dict value"
patterns -default * -type string -multiple 1 -help "key or key glob pattern"
} $args]
set opt_sep [dict get $argd opts -separator]
set opt_keysorttype [dict get $argd opts -keysorttype]
set opt_keysortdirection [dict get $argd opts -keysortdirection]
set opt_trimright [dict get $argd opts -trimright]
set opt_ansibase_key [dict get $argd opts -ansibase_keys]
set opt_ansibase_value [dict get $argd opts -ansibase_values]
set opt_return [dict get $argd opts -return]
set dval [dict get $argd values dictvalue]
set patterns [dict get $argd values patterns]
@ -456,10 +465,37 @@ namespace eval punk::lib {
#simple use of 'format' won't cut it for more complex dict keys/values
#use block::width or our columns won't align in some cases
set maxl [::tcl::mathfunc::max {*}[lmap v $filtered_keys {textblock::width $v}]]
foreach key $filtered_keys {
#append result [format "%-*s = %s" $maxl $key [dict get $dval $key]] \n
#differing height blocks (ie ragged) so we need a full textblock::join rather than join_basic
append result [textblock::join -- [textblock::pad $key -width $maxl] $opt_sep [dict get $dval $key]] \n
set RST [a]
switch -- $opt_return {
"tailtohead" {
#last line of key is side by side (possibly with separator) with first line of value
#This is more intelligible when terminal wrapping occurs - and is closer to what happens with parray multiline keys and values
#we still pad the key to max width so that the separator appears in the same column - which in the case of wide keys could cause that to wrap for all entries
foreach key $filtered_keys {
lassign [textblock::size $key] _kw kwidth _kh kheight
lassign [textblock::size [dict get $dval $key]] _vw vwidth _vh vheight
set totalheight [expr {$kheight + $vheight -1}]
set blanks_above [string repeat \n [expr {$kheight -1}]]
set blanks_below [string repeat \n [expr {$vheight -1}]]
set sepwidth [textblock::width $opt_sep]
#append result [textblock::pad $opt_ansibase_key$key$RST -width $maxl] $opt_sep $opt_ansibase_value[dict get $dval $key]$RST \n
set kblock [textblock::pad $opt_ansibase_key$key$RST$blanks_below -width $maxl]
set sblock [textblock::pad $blanks_above$opt_sep$blanks_below -width $sepwidth]
set vblock $blanks_above$opt_ansibase_value[dict get $dval $key]$RST
#only vblock is ragged - we can do a basic join because we don't care about rhs whitespace
append result [textblock::join_basic $kblock $sblock $vblock] \n
}
}
"sidebyside" {
#This is nice for multiline keys and values of reasonable length, will produce unintuitive results when line-wrapping occurs.
#use ansibase_key etc to make the output more comprehensible in that situation.
#This is why it is not the default. (review - terminal width detection and wrapping?)
foreach key $filtered_keys {
#append result [format "%-*s = %s" $maxl $key [dict get $dval $key]] \n
#differing height blocks (ie ragged) so we need a full textblock::join rather than join_basic
append result [textblock::join -- [textblock::pad $opt_ansibase_key$key$RST -width $maxl] $opt_sep "$opt_ansibase_value[dict get $dval $key]$RST"] \n
}
}
}
}
if {$opt_trimright} {
@ -1659,7 +1695,11 @@ namespace eval punk::lib {
set replaycodes $RST ;#todo - default?
set transformed [list]
#shortcircuit common case of no ansi
if {![punk::ansi::ta::detect $linelist]} {
#NOTE: running ta::detect on a list (or dict) as a whole can be problematic if items in the have backslash escapes due to Tcl list quoting and escaping behaviour.
#This commonly happens if there is an unbalanced brace (which is a normal occurrence and needs to be handled)
#ta::detect on a list of ansi-containing string may appear to work for some simple inputs but is not reliable
#detect_in_list will check at first level. (not intended for detecting ansi in deeper structures)
if {![punk::ansi::ta::detect_in_list $linelist]} {
if {$opt_ansiresets} {
foreach ln $linelist {
lappend transformed $RST$ln$RST

229
src/modules/textblock-999999.0a1.0.tm

@ -1270,22 +1270,23 @@ tcl::namespace::eval textblock {
set c 0
foreach hval $v {
#retrieve -headers from relevant col, insert at header index, and write back.
set colheaders [tcl::dict::get $o_columndefs $c -headers]
set missing [expr {($hidx +1) - [llength $colheaders]}]
set thiscol_headers_vertical [tcl::dict::get $o_columndefs $c -headers]
set missing [expr {($hidx +1) - [llength $thiscol_headers_vertical]}]
if {$missing > 0} {
lappend colheaders {*}[lrepeat $missing ""]
lappend thiscol_headers_vertical {*}[lrepeat $missing ""]
}
lset colheaders $hidx $hval
tcl::dict::set o_columndefs $c -headers $colheaders
lset thiscol_headers_vertical $hidx $hval
tcl::dict::set o_columndefs $c -headers $thiscol_headers_vertical
#invalidate column width cache
set o_calculated_column_widths [list]
# -- -- -- -- -- --
#also update maxwidthseen & maxheightseen
set i 0
set maxwidthseen 0
set maxheightseen 0
foreach hdr $colheaders {
#set maxheightseen 0
foreach hdr $thiscol_headers_vertical {
lassign [textblock::size $hdr] _w this_header_width _h this_header_height
set maxheightseen [punk::lib::dict_getdef $o_headerstates $i maxheightseen 0]
if {$this_header_height >= $maxheightseen} {
tcl::dict::set o_headerstates $i maxheightseen $this_header_height
} else {
@ -3602,8 +3603,8 @@ tcl::namespace::eval textblock {
tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export -clear}
}
proc spantest {} {
set t [list_as_table 5 {a b c d e aa bb cc dd ee X Y} -return object]
$t configure_column 0 -headers {span3 span4 span5/5 "span-all etc blah 123 hmmmmm" span2}
set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}]
$t configure_column 0 -headers [list span3 "1-span4\n2-span4 second line" span5/5 "span-all etc blah 123 hmmmmm" span2]
$t configure_column 0 -header_colspans {3 4 5 all 2}
$t configure_column 2 -headers {"" "" "" "" c2span2_etc}
$t configure_column 2 -header_colspans {0 0 0 0 2}
@ -3613,7 +3614,7 @@ tcl::namespace::eval textblock {
#more complex colspans
proc spantest2 {} {
set t [list_as_table 5 {a b c d e aa bb cc dd ee X Y} -return object]
set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}]
$t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2}
$t configure_column 0 -header_colspans {3 4 1 all 2}
$t configure_column 1 -header_colspans {0 0 2 0 0}
@ -3624,7 +3625,7 @@ tcl::namespace::eval textblock {
return $t
}
proc spantest3 {} {
set t [list_as_table 5 {a b c d e aa bb cc dd ee X Y} -return object]
set t [list_as_table -columns 5 -return tableobjec {a b c d e aa bb cc dd ee X Y}]
$t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" "c0span2 etc blah" c0span1}
$t configure_column 0 -header_colspans {3 4 1 all 2 1}
$t configure_column 1 -header_colspans {0 0 4 0 0 1}
@ -3641,22 +3642,21 @@ tcl::namespace::eval textblock {
proc periodic {args} {
#For an impressive interactive terminal app (javascript)
# see: https://github.com/spirometaxas/periodic-table-cli
set opts [dict get [punk::args::get_dict {
*proc -name textblock::periodic -help "A rudimentary periodic table
This is primarily a test of textblock::class::table"
-return -default table\
-choices {table tableobject}\
-help "default choice 'table' returns the displayable table output"
-compact -default 1 -type boolean -help "compact true defaults: -show_vseps 0 -show_header 0 -show_edge 0"
-show_vseps -default "" -type boolean
-show_header -default "" -type boolean
-show_edge -default "" -type boolean
-forcecolour -default 0 -type boolean -help "If punk::colour is off - this enables the produced table to still be ansi coloured"
*values -min 0 -max 0
} $args] opts]
set opts [tcl::dict::create\
-return "string"\
-compact 1\
-forcecolour 0\
]
foreach {k v} $args {
switch -- $k {
-return - -compact - -forcecolour {
tcl::dict::set opts $k $v
}
default {
"textblock::periodic unknown option '$k'. Known options: [tcl::dict::keys $opts]"
}
}
}
set opt_return [tcl::dict::get $opts -return]
if {[tcl::dict::get $opts -forcecolour]} {
set fc forcecolour
@ -3764,7 +3764,8 @@ tcl::namespace::eval textblock {
}
}
set t [list_as_table 19 $elements1 -return obj]
set t [list_as_table -columns 19 -return tableobject $elements1]
#(defaults to show_hseps 0)
#todo - keep simple table with symbols as base - map symbols to descriptions etc for more verbose table options
@ -3779,78 +3780,156 @@ tcl::namespace::eval textblock {
$t configure_column $c -minwidth 3
}
if {[tcl::dict::get $opts -compact]} {
$t configure -show_hseps 0 -show_header 0 -show_edge 0
#compact defaults - but let explicit arguments override
set conf [dict create -show_vseps 0 -show_header 0 -show_edge 0]
} else {
$t configure -show_header 1
set conf [dict create -show_vseps 1 -show_header 1 -show_edge 1]
}
dict for {k v} $conf {
if {[dict get $opts $k] ne ""} {
dict set conf $k [dict get $opts $k]
}
}
$t configure {*}[dict get $conf]
if {$opt_return eq "string"} {
$t configure \
-frametype_header light\
-ansiborder_header [a+ {*}$fc web-white]\
-ansibase_header [a+ {*}$fc Web-black]\
-ansibase_body [a+ {*}$fc Web-black]\
-ansiborder_body [a+ {*}$fc web-black]\
-frametype block
$t configure \
-frametype_header light\
-ansiborder_header [a+ {*}$fc web-white]\
-ansibase_header [a+ {*}$fc Web-black]\
-ansibase_body [a+ {*}$fc Web-black]\
-ansiborder_body [a+ {*}$fc web-black]\
-frametype block
if {$opt_return eq "table"} {
set output [textblock::frame -ansiborder [a+ {*}$fc Web-black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Web-black] Periodic Table " [$t print]]
$t destroy
return $output
}
return $t
}
proc list_as_table {table_or_colcount datalist args} {
set opts [tcl::dict::create\
-return string\
-frametype \uFFEF\
-show_edge \uFFEF\
-show_seps \uFFEF\
]
foreach {k v} $args {
switch -- $k {
-return - -show_edge - -show_seps - -frametype {
tcl::dict::set opts $k $v
}
default {
error "unrecognised option '$k'. Known options [tcl::dict::keys $opts]"
}
}
}
proc list_as_table {args} {
set argd [punk::args::get_dict [string map [list <ftypes> $::textblock::frametypes] {
-return -default table -choices {table tableobject}
-frametype -default "" -help "frame type: <ftypes> or dict for custom frame"
-show_edge -default "" -type boolean -help "show outer border of table"
-show_seps -default "" -type boolean
-show_vseps -default "" -type boolean -help "Show vertical table separators"
-show_hseps -default "" -type boolean -help "Show horizontal table separators
(default 0 if no existing -table supplied)"
-table -default "" -type string -help "existing table object to use"
-headers -default "" -help "list of header values. Must match number of columns"
-action -default "append" -choices {append replace} -help "row insertion method if existing -table is supplied
if append is chosen the new values will always start at the first column"
-columns -default "" -type integer -help "Number of table columns
Will default to 2 if not using an existing -table object"
*values
datalist -default {} -help "flat list of table cell values which will be wrapped based on -columns value"
}] $args]
set opts [dict get $argd opts]
set datalist [dict get $argd values datalist]
set existing_table [dict get $opts -table]
set opt_columns [dict get $opts -columns]
#set opts [tcl::dict::create\
# -return string\
# -frametype \uFFEF\
# -show_edge \uFFEF\
# -show_seps \uFFEF\
#]
#foreach {k v} $args {
# switch -- $k {
# -return - -show_edge - -show_seps - -frametype {
# tcl::dict::set opts $k $v
# }
# default {
# error "unrecognised option '$k'. Known options [tcl::dict::keys $opts]"
# }
# }
#}
set count [llength $datalist]
set is_new_table 0
if {[tcl::string::is integer -strict $table_or_colcount]} {
set cols $table_or_colcount
if {$existing_table ne ""} {
if {[tcl::namespace::tail [info object class $existing_table]] ne "table"} {
error "textblock::list_as_table error -table must be an existing table object (e.g set t \[textblock::class::table new\])"
}
set t $existing_table
foreach prop {-frametype -show_edge -show_seps -show_vseps -show_hseps} {
if {[tcl::dict::get $opts $prop] ne ""} {
$t configure $prop [tcl::dict::get $opts $prop]
}
}
if {[dict get $opts -action] eq "replace"} {
$t row_clear
}
set cols [$t column_count]
if {[tcl::string::is integer -strict $opt_columns]} {
if {$opt_columns > $cols} {
set extra [expr {$opt_columns - $cols}]
for {set c 0} {$c < $extra} {incr c} {
$t add_column
}
} elseif {$opt_columns < $cols} {
#todo - auto add blank values in the datalist
error "Number of columns requested: $opt_columns is less than existing number of columns $cols - not yet supported"
}
set cols [$t column_count]
}
} else {
set is_new_table 1
if {[tcl::string::is integer -strict $opt_columns]} {
set cols $opt_columns
} else {
#review
set cols 2 ;#seems a reasonable default
}
#defaults for new table only
if {[tcl::dict::get $opts -frametype] eq "\uFFEF"} {
if {[tcl::dict::get $opts -frametype] eq ""} {
tcl::dict::set opts -frametype "light"
}
if {[tcl::dict::get $opts -show_edge] eq "\uFFEF"} {
if {[tcl::dict::get $opts -show_edge] eq ""} {
tcl::dict::set opts -show_edge 1
}
if {[tcl::dict::get $opts -show_seps] eq "\uFFEF"} {
if {[tcl::dict::get $opts -show_seps] eq ""} {
tcl::dict::set opts -show_seps 1
}
set t [textblock::class::table new -show_header 0 -show_edge [tcl::dict::get $opts -show_edge] -frametype [tcl::dict::get $opts -frametype] -show_seps [tcl::dict::get $opts -show_seps]]
for {set c 0} {$c < $cols} {incr c} {
$t add_column -headers [list $c]
if {[tcl::dict::get $opts -show_vseps] eq ""} {
tcl::dict::set opts -show_vseps 1
}
} else {
if {[tcl::namespace::tail [info object class $table_or_colcount]] ne "table"} {
error "textblock::list_as_table error - table_or_colcount must be an integer or an existing table object"
if {[tcl::dict::get $opts -show_hseps] eq ""} {
tcl::dict::set opts -show_hseps 0
}
set t $table_or_colcount
if {[tcl::dict::get $opts -frametype] ne "\uFFEF"} {
$t configure -frametype [tcl::dict::get $opts -frametype]
set headers {}
set show_header 0
if {[tcl::dict::get $opts -headers] ne ""} {
set headers [dict get $opts -headers]
if {[llength $headers] ne $cols} {
error "list_as_table number of headers ([llength $headers]) must match number of columns ($cols)"
}
set show_header 1
}
if {[tcl::dict::get $opts -show_edge] ne "\uFFEF"} {
$t configure -show_edge [tcl::dict::get $opts -show_edge]
set t [textblock::class::table new\
-show_header $show_header\
-show_edge [tcl::dict::get $opts -show_edge]\
-frametype [tcl::dict::get $opts -frametype]\
-show_seps [tcl::dict::get $opts -show_seps]\
-show_vseps [tcl::dict::get $opts -show_vseps]\
-show_hseps [tcl::dict::get $opts -show_hseps]\
]
if {[llength $headers]} {
for {set c 0} {$c < $cols} {incr c} {
$t add_column -headers [lindex $headers $c]
}
} else {
for {set c 0} {$c < $cols} {incr c} {
$t add_column -headers [list $c]
}
}
$t row_clear
set cols [$t column_count]
}
set full_rows [expr {$count / $cols}]
set last_items [expr {$count % $cols}]
@ -3878,7 +3957,7 @@ tcl::namespace::eval textblock {
$t add_row $row
}
#puts stdout $rowdata
if {[tcl::dict::get $opts -return] eq "string"} {
if {[tcl::dict::get $opts -return] eq "table"} {
set result [$t print]
if {$is_new_table} {
$t destroy
@ -4400,7 +4479,7 @@ tcl::namespace::eval textblock {
set testlist [list "within_ansi 0" $left0 $right0 "within_ansi 1" $left1 $right1 "within_ansi 2" $left2 $right2]
set t [textblock::list_as_table 3 $testlist -return object]
set t [textblock::list_as_table -columns 3 -return tableobject $testlist]
$t configure_column 0 -headers [list "ansi"]
$t configure_column 1 -headers [list "Left"]
$t configure_column 2 -headers [list "Right"]
@ -4478,7 +4557,7 @@ tcl::namespace::eval textblock {
set column_ansi [a+ web-white Web-Gray]
set t [textblock::list_as_table [expr {1 + (2 * [tcl::dict::size $blockinfo])}] $rows -return object]
set t [textblock::list_as_table -columns [expr {1 + (2 * [tcl::dict::size $blockinfo])}] -return tableobject $rows]
$t configure_column 0 -headers [list [tcl::dict::get $opts -description] "within_ansi"] -ansibase $column_ansi
set col 1
tcl::dict::for {b bdict} $blockinfo {

Loading…
Cancel
Save