tools.tree: adding "tree" tool.

diff --git a/extra/tools/tree/authors.txt b/extra/tools/tree/authors.txt
new file mode 100644 (file)
index 0000000..e091bb8
--- /dev/null
+++ b/extra/tools/tree/authors.txt
@@ -0,0 +1 @@
+John Benediktsson

diff --git a/extra/tools/tree/deploy.factor b/extra/tools/tree/deploy.factor
new file mode 100644 (file)
index 0000000..59bba7b
--- /dev/null
+++ b/extra/tools/tree/deploy.factor
@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-name "tree" }
+    { deploy-ui? f }
+    { deploy-c-types? f }
+    { deploy-console? t }
+    { deploy-unicode? f }
+    { "stop-after-last-window?" t }
+    { deploy-io 3 }
+    { deploy-reflection 6 }
+    { deploy-word-props? f }
+    { deploy-math? t }
+    { deploy-threads? t }
+    { deploy-word-defs? f }
+}

diff --git a/extra/tools/tree/tree.factor b/extra/tools/tree/tree.factor
new file mode 100644 (file)
index 0000000..ad0c2e8
--- /dev/null
+++ b/extra/tools/tree/tree.factor
@@ -0,0 +1,62 @@
+! Copyright (C) 2011 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors command-line continuations formatting io
+io.directories io.files.types io.pathnames kernel locals math
+namespaces sequences sorting ;
+FROM: namespaces => change-global ;
+IN: tools.tree
+
+SYMBOL: #files
+SYMBOL: #directories
+
+: indent ( indents -- )
+    unclip-last-slice
+    [ [ "    " "|   " ? write ] each ]
+    [ "└── " "├── " ? write ] bi* ;
+
+: write-name ( entry indents -- )
+    indent name>> write ;
+
+: write-file ( entry indents -- )
+    write-name #files [ 1 + ] change-global ;
+
+DEFER: write-tree
+
+: write-dir ( entry indents -- )
+    [ write-name ] [
+        [ [ name>> ] dip write-tree ]
+        [ 3drop " [error opening dir]" write ] recover
+    ] 2bi #directories [ 1 + ] change-global ;
+
+: write-entry ( entry indents -- )
+    nl over type>> +directory+ =
+    [ write-dir ] [ write-file ] if ;
+
+:: write-tree ( path indents -- )
+    path [
+        [ name>> ] sort-with [ ] [
+            unclip-last [
+                f indents push
+                [ indents write-entry ] each
+            ] [
+                indents pop* t indents push
+                indents write-entry
+            ] bi* indents pop*
+        ] if-empty
+    ] with-directory-entries ;
+
+: tree ( path -- )
+    0 #directories set-global 0 #files set-global
+    [ write ] [ V{ } clone write-tree ] bi nl
+    #directories get-global #files get-global
+    "\n%d directories, %d files\n" printf ;
+
+: run-tree ( -- )
+    command-line get [
+        current-directory get tree
+    ] [
+        [ tree ] each
+    ] if-empty ;
+
+MAIN: run-tree