# HG changeset patch
# User xaltsc <hey+dev@xaltsc.dev>
# Date 1636876636 -3600
#      Sun Nov 14 08:57:16 2021 +0100
# Node ID 23d2b7e4e7b4291d1a8a5cdd531917cd93e25585
# Parent  8d32c7900cba20b81b151d055722d00ce2719e05
zsh: add zsh gen named dirs

diff --git a/jd/filesystem.scm b/jd/filesystem.scm
--- a/jd/filesystem.scm
+++ b/jd/filesystem.scm
@@ -3,7 +3,7 @@
   (use jd.structures)
   (use jd.trees)
   (use jd.util)
-  (export jd:root jd:file-tree))
+  (export jd:root jd:file-tree jd:file-tree-with-full-paths))
 
 (select-module jd.filesystem)
 
@@ -17,6 +17,7 @@
     :absolute #t :expand #t :canonicalize #t))
 
 (define jd:file-tree (cut jd:tree (jd:root)))
+(define jd:file-tree-with-full-paths (cut jd:tree-with-full-paths (jd:root)))
 
 ;;; TRANSFORM DATA FROM FILESYSTEM TO SCHEME DATA
 
@@ -32,6 +33,17 @@
          (make-jd:record jd:num label 
                          (list (make-jd:record-instance type path))
                          #f #f))))))
+(define file->jd:record-with-full-path
+  ;; converts a path to a jd:record
+  ;; the second optional argument 'type' guesses the type from the filesystem
+  ;; if not provided.
+  (lambda (path :optional (type (file-type path :follow-link? #t)))
+    (let [(basename (sys-basename path))]
+      (let-values [((raw-id raw-label) (string-scan basename #\- 'both))]
+        (let [(jd:num (numstring->numspec raw-id))]
+         (make-jd:record jd:num path 
+                         (list (make-jd:record-instance type path))
+                         #f #f))))))
 
 (define jd:tree
   ;; converts a file tree to a JD-tree if pathnames are valid JD ids.
@@ -55,4 +67,27 @@
                             root-path))]
         (make-node root-label (map map-fn jd:elts))))))
 
-
+(define jd:tree-with-full-paths
+  ;; converts a file tree to a JD-tree if pathnames are valid JD ids.
+  ;; the tree is a list according to the following grammar:
+  ;; T        := (label children) | Ø
+  ;; label    := jd:record
+  ;; children := list[T]
+  ;; The root is still placed at the top of the tree, only the children of the
+  ;; resulting tree follows the grammar above.
+  (let [(map-fn (lambda (path)
+                    (case (file-type path :follow-link? #t)
+                      [(directory) (jd:tree-with-full-paths path)]
+                      [else => (.$ make-node 
+                                   (pa$ file->jd:record-with-full-path
+                                        path))])))]
+    (lambda (root-path)
+      (let [(jd:elts (directory-list root-path
+                                     :add-path? #t
+                                     :children? #t
+                                     :filter johnny?))
+            (root-label (if ($ johnny? $ sys-basename root-path)
+                            (file->jd:record-with-full-path 
+                              root-path 'directory)
+                            root-path))]
+        (make-node root-label (map map-fn jd:elts))))))
diff --git a/jd/trees.scm b/jd/trees.scm
--- a/jd/trees.scm
+++ b/jd/trees.scm
@@ -172,7 +172,7 @@
            [children1 (node-children tree1)]
            [children2 (node-children tree2)]
            [new-label (if (and (jd:record? label1) (jd:record? label2)) 
-                              (jd:record-append label2 label1) label1)]
+                          (jd:record-append label2 label1) label1)]
            [new-children (jd:fetch-info-from-second-node-list
                            children1 children2)])
       (make-node new-label new-children))))
diff --git a/jd/zsh.scm b/jd/zsh.scm
--- a/jd/zsh.scm
+++ b/jd/zsh.scm
@@ -4,6 +4,7 @@
   (use jd.filesystem)
   (use jd.meta)
   (export jd:generate-zsh-completions
+          jd:generate-zsh-named-folders
           jd:full-info-tree))
 
 (select-module jd.zsh)
@@ -36,4 +37,21 @@
       ""
       jd-file-tree)))
 
-
+(define jd:generate-zsh-named-folders
+  (lambda [jd-file-tree]
+    (fold-tree 
+      (lambda [fst ls] 
+        (let1 purged (filter (complement (pa$ equal? "")) (cons fst ls))
+          (string-join purged "\n")))
+      (lambda [_ record]
+        (if (or ($ not $ jd:record? record) 
+                ($ not $ any (pa$ eq? 'directory) 
+                             (map jd:record-instance-type
+                                  (jd:record-instances record))))
+            ""
+          (let [(num-string ($ num-format $ jd:record-number record))
+                (rec-label  (jd:record-label record))]
+            (format "hash -d j~a='~a'" num-string rec-label))))
+      (lambda [_ _] "") 
+      ""
+      jd-file-tree)))
diff --git a/johnny.scm b/johnny.scm
--- a/johnny.scm
+++ b/johnny.scm
@@ -6,6 +6,7 @@
 (add-load-path "." :relative)
 
 (use jd.zsh)
+(use jd.filesystem)
 
 
 ;(define jd:full-tree
@@ -19,6 +20,10 @@
   (lambda (args)
     (let1 argv (cdr args)
       (ecase ($ string->symbol $ car argv)
-        [(--complete)
-         (format (current-output-port) "~a" (jd:generate-zsh-completions (jd:full-info-tree)))
+        [(--complete) (format #t "~a" (jd:generate-zsh-completions 
+                                        (jd:full-info-tree)))
+                      0]
+        [(--gen-named-folders) 
+         (format #t "~a" (jd:generate-zsh-named-folders
+                           (jd:file-tree-with-full-paths)))
          0]))))