package provide punk::lib [namespace eval punk::lib {
variable version
set version 0.1
}]
namespace eval punk::lib {
>pattern .. Create >libpattern ;#clone to a library factory
>libpattern .. Construct {args} {
var o_this
set o_this @this@
var o_last_child
set o_last_child ""
}
>libpattern .. Method version {} {
return 1.0.0
}
>libpattern .. Method aliasprefix {pfx} {
var o_this
var o_last_child
if {![string length $o_last_child]} {
error " . aliasprefix - Create library object with . new >somename first."
}
set patternmethods [$o_this .. PM]
set aliases [list]
foreach m $patternmethods {
set a ${pfx}${m}
if {[llength [info commands $a]]} {
puts stderr "WARNING - a command was already present at: $a"
}
interp alias "" $a "" [$o_last_child . $m .]
lappend aliases $a
}
return $aliases
}
>libpattern .. Method new {objcmdname} {
var o_this
set o_this @this@
var o_last_child
set nscaller [uplevel 1 [list namespace current]]
if {![string match ::* $objcmdname]} {
if {$nscaller eq "::"} {set nscaller ""}
set objcmdname ${nscaller}::$objcmdname
}
uplevel 1 [list $o_this .. Create $objcmdname]
set o_last_child $objcmdname
}
>libpattern .. Constructor {args} {
var o_this
set o_this @this@
}
>libpattern .. Clone >ls_lib
>ls_lib .. PatternMethod tail {args} {
if {![llength $args]} {
error "argumenterror cannot retrieve tail on an empty input list" ">ls_lib . tail $args" [list argumenterror tail empty_list]
}
lrange $args 1 end
}
>ls_lib .. PatternMethod init {args} {
if {![llength $args]} {
error "argumenterror cannot retrieve init on an empty input list" ">ls_lib . init $args" [list argumenterror init empty_list]
}
lrange $args 0 end-1
}
>ls_lib .. PatternMethod head {args} {
if {![llength $args]} {
error "argumenterror cannot retrieve head on an empty input list" ">ls_lib . head $args" [list argumenterror head empty_list]
}
lindex $args 0
}
>ls_lib .. PatternMethod last {args} {
if {![llength $args]} {
error "argumenterror cannot retrieve last on an empty input list. Use li.index end to avoid list length check" ">ls_lib . last $args" [list argumenterror last empty_list]
}
lindex $args end
}
>ls_lib .. PatternMethod elem {val args} {
expr {$val in $args}
}
>ls_lib .. PatternMethod index {idx args} {
lindex $args $idx
}
>ls_lib .. PatternMethod range {s e args} {
lrange $args $s $e
}
#take/drop - haskell-like - but no lazy support REVIEW
#see also https://www.haskellforall.com/2022/05/why-does-haskells-take-function-accept.html
>ls_lib .. PatternMethod take {n args} {
#keep basic behaviour like Haskell ie we allow returning less than n (without error) if insufficient elements
lrange $args 0 $n-1
}
>ls_lib .. PatternMethod drop {n args} {
lrange $args $n end
}
>ls_lib . new >ls
>ls_lib . aliasprefix "ls."
#list item lib
>libpattern .. Clone >li_lib
>li_lib .. PatternMethod tail {listdata} {
if {![llength $listdata]} {
error "argumenterror cannot retrieve tail on an empty input list" ">li_lib . tail $listdata" [list argumenterror tail empty_list]
}
lrange $listdata 1 end
}
>li_lib .. PatternMethod init {listdata} {
if {![llength $listdata]} {
error "argumenterror cannot retrieve init on an empty input list" ">li_lib . init $listdata" [list argumenterror init empty_list]
}
lrange $listdata 0 end-1
}
>li_lib .. PatternMethod head {listdata} {
if {![llength $listdata]} {
error "argumenterror cannot retrieve head on an empty input list" ">li_lib . head $listdata" [list argumenterror head empty_list]
}
lindex $listdata 0
}
>li_lib .. PatternMethod last {listdata} {
if {![llength $listdata]} {
error "argumenterror cannot retrieve last on an empty input list. Use li.index end to avoid list length check" ">li_lib . last $listdata" [list argumenterror last empty_list]
}
lindex $listdata end
}
>li_lib .. PatternMethod elem {val listdata} {
expr {$val in $listdata}
}
>li_lib .. PatternMethod index {idx listdata} {
lindex $listdata $idx
}
>li_lib .. PatternMethod range {s e listdata} {
lrange $listdata $s $e
}
#take/drop - haskell-like - but no lazy support REVIEW
#see also https://www.haskellforall.com/2022/05/why-does-haskells-take-function-accept.html
>li_lib .. PatternMethod take {n listdata} {
#keep basic behaviour like Haskell ie we allow returning less than n (without error) if insufficient elements
#if not specified - add a single module matching project name
set opt_modules [list $projectname]
}
set opt_type [dict get $opts -type]
if {$opt_type ni [lib::module_types]} {
error "pmix new error - unknown type '$opt_type' known types: [lib::module_types]"
}
set opt_layout [dict get $opts -layout]
set opt_force [dict get $opts -force]
set opt_update [dict get $opts -update]
set opt_confirm [string tolower [dict get $opts -confirm]]
set startdir [pwd]
if {[lib::is_project_dir $startdir]} {
puts stderr "Already in a project directory '$startdir' - move to a base location suitable for a new project"
return
}
set projectdir $startdir/$projectname
set tpldir [lib::mix_templates_dir]
if {[file exists $projectdir] && !($opt_force || $opt_update)} {
error "Unable to create new project at $projectdir - file/folder already exists use -update 1 to fill in missing items from template use -force 1 to overwrite from template"
set subpath [lib::module_subpath $modulename] ;#commonly empty string for simple modulename e.g "mymodule" but x::mymodule has subpath 'x' and x::y::mymodule has subpath 'x/y'
if {![string length $subpath]} {
set modulefolder $projectdir/src/modules
} else {
set modulefolder $projectdir/src/modules/$subpath
}
file mkdir $modulefolder
set moduletail [namespace tail $modulename]
set tpldir [lib::mix_templates_dir]
set magicversion [lib::magic_tm_version] ;#deliberately large so given load-preference when testing
set fd [open $tpldir/module/module_buildversion.txt r]; set filedata [read $fd]; close $fd
set filedata [string map [list %Major.Minor.Level% $opt_version] $filedata]
set fd [open $modulefolder/${moduletail}-buildversion.txt w]
fconfigure $fd -translation binary
puts -nonewline $fd $filedata
close $fd
set tpldir [lib::mix_templates_dir]
set fd [open $tpldir/module/module_template-0.0.1.tm r]; set filedata [read $fd]; close $fd
#review to see if tcl tm system allows semver style x.y.z-beta etc or if we should lock it down
#need to take into account how tcl compares/orders version numbers.
if {(![string first a $tailpart] >= 0) && (![string first b $tailpart] >=0)} {
return 0
}
}
}
return 1
}
set commands [namespace export]
set helpstr ""
append helpstr "commands:\n"
foreach cmd $commands {
append helpstr " $cmd"
#Note that semver only has a small overlap with tcl tm versions.
#todo - work out what overlap and whether it's even useful
#see also TIP #439: Semantic Versioning (tcl 9??)
proc semver {versionstring} {
set re {^(0|[1-9]\d*)\.(0|[1-9]\d*)\.(0|[1-9]\d*)(?:-((?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*)(?:\.(?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*))*))?(?:\+([0-9a-zA-Z-]+(?:\.[0-9a-zA-Z-]+)*))?$}
}
proc magic_tm_version {} {
return 999999.0a1.0 ;#deliberately large so given load-preference when testing
