Adding .tm Tcl samples

2025-10-29 17:50:22 +00:00 · 2014-04-21 11:04:23 -05:00
parent a265237b2e
commit 20c9ed9f36
3 changed files with 406 additions and 3 deletions
--- a/lib/linguist/samples.json
+++ b/lib/linguist/samples.json
@@ -455,6 +455,9 @@
      ".svh",
      ".vh"
    ],
+    "Tcl": [
+      ".tm"
+    ],
    "Tea": [
      ".tea"
    ],
@@ -575,8 +578,8 @@
      ".gemrc"
    ]
  },
-  "tokens_total": 456690,
-  "languages_total": 569,
+  "tokens_total": 457823,
+  "languages_total": 571,
  "tokens": {
    "ABAP": {
      "*/**": 1,
@@ -45948,6 +45951,127 @@
      "x": 6,
      "endfunction": 1
    },
+    "Tcl": {
+      "#": 7,
+      "package": 2,
+      "require": 2,
+      "Tcl": 2,
+      "namespace": 6,
+      "eval": 2,
+      "stream": 61,
+      "{": 148,
+      "export": 3,
+      "[": 76,
+      "a": 1,
+      "-": 5,
+      "z": 1,
+      "]": 76,
+      "*": 19,
+      "}": 148,
+      "ensemble": 1,
+      "create": 7,
+      "proc": 28,
+      "first": 24,
+      "restCmdPrefix": 2,
+      "return": 22,
+      "list": 18,
+      "lassign": 11,
+      "foldl": 1,
+      "cmdPrefix": 19,
+      "initialValue": 7,
+      "args": 13,
+      "set": 34,
+      "numStreams": 3,
+      "llength": 5,
+      "if": 14,
+      "FoldlSingleStream": 2,
+      "lindex": 5,
+      "elseif": 3,
+      "FoldlMultiStream": 2,
+      "else": 5,
+      "Usage": 4,
+      "foreach": 5,
+      "numArgs": 7,
+      "varName": 7,
+      "body": 8,
+      "ForeachSingleStream": 2,
+      "(": 11,
+      ")": 11,
+      "&&": 2,
+      "%": 1,
+      "end": 2,
+      "items": 5,
+      "lrange": 1,
+      "ForeachMultiStream": 2,
+      "fromList": 2,
+      "_list": 4,
+      "index": 4,
+      "expr": 4,
+      "+": 1,
+      "isEmpty": 10,
+      "map": 1,
+      "MapSingleStream": 3,
+      "MapMultiStream": 3,
+      "rest": 22,
+      "select": 2,
+      "while": 6,
+      "take": 2,
+      "num": 3,
+      "||": 1,
+      "<": 1,
+      "toList": 1,
+      "res": 10,
+      "lappend": 8,
+      "#################################": 2,
+      "acc": 9,
+      "streams": 5,
+      "firsts": 6,
+      "restStreams": 6,
+      "uplevel": 4,
+      "nextItems": 4,
+      "msg": 1,
+      "code": 1,
+      "error": 1,
+      "level": 1,
+      "XDG": 11,
+      "variable": 4,
+      "DEFAULTS": 8,
+      "DATA_HOME": 4,
+      "CONFIG_HOME": 4,
+      "CACHE_HOME": 4,
+      "RUNTIME_DIR": 3,
+      "DATA_DIRS": 4,
+      "CONFIG_DIRS": 4,
+      "SetDefaults": 3,
+      "ne": 2,
+      "file": 9,
+      "join": 9,
+      "env": 8,
+      "HOME": 3,
+      ".local": 1,
+      "share": 3,
+      ".config": 1,
+      ".cache": 1,
+      "/usr": 2,
+      "local": 1,
+      "/etc": 1,
+      "xdg": 1,
+      "XDGVarSet": 4,
+      "var": 11,
+      "info": 1,
+      "exists": 1,
+      "XDG_": 4,
+      "Dir": 4,
+      "subdir": 16,
+      "dir": 5,
+      "dict": 2,
+      "get": 2,
+      "Dirs": 3,
+      "rawDirs": 3,
+      "split": 1,
+      "outDirs": 3,
+      "XDG_RUNTIME_DIR": 1
+    },
    "Tea": {
      "<%>": 1,
      "template": 1,
@@ -49702,6 +49826,7 @@
    "Stylus": 76,
    "SuperCollider": 133,
    "SystemVerilog": 541,
+    "Tcl": 1133,
    "Tea": 3,
    "TeX": 2701,
    "Turing": 44,
@@ -49853,6 +49978,7 @@
    "Stylus": 1,
    "SuperCollider": 1,
    "SystemVerilog": 4,
+    "Tcl": 2,
    "Tea": 1,
    "TeX": 2,
    "Turing": 1,
@@ -49873,5 +49999,5 @@
    "Xtend": 2,
    "YAML": 2
  },
-  "md5": "369eb61211321cd0a217de22110731ac"
+  "md5": "0cf73610115419ee252a48415b538180"
 }
--- a/samples/Tcl/stream-0.1.tm
+++ b/samples/Tcl/stream-0.1.tm
@@ -0,0 +1,201 @@
+# A stream ensemble
+#
+# Copyright (c) 2013 Lawrence Woodman <lwoodman@vlifesystems.com>
+#
+# Licensed under an MIT licence.  Please see LICENCE.md for details.
+#
+
+package require Tcl 8.5
+
+namespace eval stream {
+  namespace export {[a-z]*}
+  namespace ensemble create
+}
+
+proc stream::create {first restCmdPrefix} {
+  return [list $first $restCmdPrefix]
+}
+
+proc stream::first {stream} {
+  lassign $stream first
+  return $first
+}
+
+proc stream::foldl {cmdPrefix initialValue args} {
+  set numStreams [llength $args]
+  if {$numStreams == 1} {
+    FoldlSingleStream $cmdPrefix $initialValue [lindex $args 0]
+  } elseif {$numStreams > 1} {
+    FoldlMultiStream $cmdPrefix $initialValue $args
+  } else {
+    Usage "stream foldl cmdPrefix initalValue stream ?stream ..?"
+  }
+}
+
+proc stream::foreach {args} {
+  set numArgs [llength $args]
+  if {$numArgs == 3} {
+    lassign $args varName stream body
+    ForeachSingleStream $varName $stream $body
+  } elseif {($numArgs > 3) && (($numArgs % 2) == 1)} {
+    set body [lindex $args end]
+    set items [lrange $args 0 end-1]
+    ForeachMultiStream $items $body
+  } else {
+    Usage "stream foreach varName stream ?varName stream ..? body"
+  }
+}
+
+proc stream::fromList {_list {index 0}} {
+  if {$index >= [llength $_list]} {return {}}
+  create [lindex $_list $index] [list fromList $_list [expr {$index + 1}]]
+}
+
+proc stream::isEmpty {stream} {
+  expr {[llength $stream] == 0}
+}
+
+proc stream::map {cmdPrefix args} {
+  set numArgs [llength $args]
+  if {$numArgs == 1} {
+    MapSingleStream $cmdPrefix [lindex $args 0]
+  } elseif {$numArgs > 1} {
+    MapMultiStream $cmdPrefix $args
+  } else {
+    Usage "stream map cmdPrefix stream ?stream ..?"
+  }
+}
+
+proc stream::rest {stream} {
+  set rest [lindex $stream 1]
+  {*}$rest
+}
+
+# Note: This will work through the elements of the stream until it finds
+# the first element that is matched by the cmdPrefix predicate.
+proc stream::select {cmdPrefix stream} {
+  while {![isEmpty $stream]} {
+    lassign $stream first rest
+    if {[{*}$cmdPrefix $first]} {
+      return [create $first [list select $cmdPrefix [{*}$rest]]]
+    } else {
+      set stream [{*}$rest]
+    }
+  }
+  return $stream
+}
+
+proc stream::take {num stream} {
+  if {[isEmpty $stream] || $num <= 0} {
+    return [::list]
+  } else {
+    lassign $stream first rest
+    create $first [list take [expr {$num - 1}] [{*}$rest]]
+  }
+}
+
+proc stream::toList {stream} {
+  set res [::list]
+  while {![isEmpty $stream]} {
+    lassign $stream first rest
+    lappend res $first
+    set stream [{*}$rest]
+  }
+  return $res
+}
+
+
+#################################
+#           Internal
+#################################
+
+proc stream::FoldlSingleStream {cmdPrefix initialValue stream} {
+  set acc $initialValue
+  while {![isEmpty $stream]} {
+    lassign $stream first rest
+    set acc [{*}$cmdPrefix $acc $first]
+    set stream [{*}$rest]
+  }
+  return $acc
+}
+
+proc stream::FoldlMultiStream {cmdPrefix initialValue streams} {
+  set acc $initialValue
+
+  while 1 {
+    set firsts [::list]
+    set restStreams [::list]
+    ::foreach stream $streams {
+      if {[isEmpty $stream]} {
+        return $acc
+      }
+      lassign $stream first rest
+      lappend firsts $first
+      lappend restStreams [{*}$rest]
+    }
+    set acc [{*}$cmdPrefix $acc {*}$firsts]
+    set streams $restStreams
+  }
+  return $acc
+}
+
+proc stream::ForeachSingleStream {varName stream body} {
+  set res {}
+  while {![isEmpty $stream]} {
+    lassign $stream first rest
+    uplevel 2 [list set $varName $first]
+    set stream [{*}$rest]
+    set res [uplevel 2 $body]
+  }
+  return $res
+}
+
+proc stream::ForeachMultiStream {items body} {
+  set res {}
+
+  while 1 {
+    set nextItems [::list]
+    ::foreach {varName stream} $items {
+      if {[isEmpty $stream]} {
+        return $res
+      }
+      lassign $stream first rest
+      uplevel 2 [list set $varName $first]
+      lappend nextItems $varName
+      lappend nextItems [{*}$rest]
+    }
+    set res [uplevel 2 $body]
+    set items $nextItems
+  }
+
+  return $res
+}
+
+proc stream::MapSingleStream {cmdPrefix stream} {
+  if {[isEmpty $stream]} {
+    return $stream
+  }
+  lassign $stream first rest
+  create [{*}$cmdPrefix $first] [list MapSingleStream $cmdPrefix [{*}$rest]]
+}
+
+proc stream::MapMultiStream {cmdPrefix streams} {
+  set firsts [::list]
+  set restStreams [::list]
+
+  ::foreach stream $streams {
+    if {[isEmpty $stream]} {
+      return $stream
+    }
+    lassign $stream first rest
+    lappend firsts $first
+    lappend restStreams [{*}$rest]
+  }
+
+  return [create [{*}$cmdPrefix {*}$firsts] \
+                 [list MapMultiStream $cmdPrefix $restStreams]]
+}
+
+proc stream::Usage {msg} {
+  return -code error -level 2 "wrong # args: should be \"$msg\""
+}
--- a/samples/Tcl/xdgbasedir-0.3.tm
+++ b/samples/Tcl/xdgbasedir-0.3.tm
@@ -0,0 +1,76 @@
+# XDG Base Directory Specification handling
+#
+# Copyright (C) 2013 Lawrence Woodman
+#
+# Licensed under an MIT licence.  Please see LICENCE.md for details.
+#
+# For XDG Base Directory Specification
+#   http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html
+#
+package require Tcl 8.5
+
+namespace eval XDG {
+  variable DEFAULTS ""
+  namespace export DATA_HOME CONFIG_HOME CACHE_HOME
+  namespace export RUNTIME_DIR DATA_DIRS CONFIG_DIRS
+}
+
+proc XDG::SetDefaults {} {
+  variable DEFAULTS
+  if {$DEFAULTS ne ""} return
+  set DEFAULTS [list \
+    DATA_HOME   [file join $::env(HOME) .local share] \
+    CONFIG_HOME [file join $::env(HOME) .config] \
+    CACHE_HOME  [file join $::env(HOME) .cache] \
+    DATA_DIRS   [list [file join /usr local share] [file join /usr share]] \
+    CONFIG_DIRS [list [file join /etc xdg ]]
+  ]
+}
+
+proc XDG::XDGVarSet {var} {
+  expr {[info exists ::env(XDG_$var)] && $::env(XDG_$var) ne ""}
+}
+
+proc XDG::Dir {var {subdir ""} } {
+  variable DEFAULTS
+  SetDefaults
+  set dir [dict get $DEFAULTS $var]
+
+  if {[XDGVarSet $var]} {
+    set dir $::env(XDG_$var)
+  }
+
+  return [file join $dir $subdir]
+}
+
+proc XDG::Dirs {var {subdir ""} } {
+  variable DEFAULTS
+  SetDefaults
+  set rawDirs [dict get $DEFAULTS $var]
+
+  if {[XDGVarSet $var]} {
+    set rawDirs [split $::env(XDG_$var) ":"]
+  }
+
+  set outDirs {}
+  foreach dir $rawDirs {
+    lappend outDirs [file join $dir $subdir]
+  }
+  return $outDirs
+}
+
+# The remaining procs reference the environmental variables XDG_
+# followed by the proc name.
+proc XDG::DATA_HOME {{subdir ""}} {Dir DATA_HOME $subdir}
+proc XDG::CONFIG_HOME {{subdir ""}} {Dir CONFIG_HOME $subdir}
+proc XDG::CACHE_HOME {{subdir ""}} {Dir CACHE_HOME $subdir}
+
+proc XDG::RUNTIME_DIR {{subdir ""}} {
+  if {![XDGVarSet RUNTIME_DIR]} { return {} }
+  return [file join $::env(XDG_RUNTIME_DIR) $subdir]
+}
+
+# The following procs returning the directories as a list with the most
+# important first.
+proc XDG::DATA_DIRS {{subdir ""}} {Dirs DATA_DIRS $subdir}
+proc XDG::CONFIG_DIRS {{subdir ""}} {Dirs CONFIG_DIRS $subdir}