A => jd/filesystem.scm +58 -0
@@ 0,0 1,58 @@
+(define-module jd.filesystem
+ (use file.util)
+ (use jd.structures)
+ (use jd.trees)
+ (use jd.util)
+ (export jd:root jd:file-tree))
+
+(select-module jd.filesystem)
+
+
+;;; GET DATA FROM SYSENV
+;;; We define all data as functions as they may not work on all systems
+
+(define jd:root
+ (cut sys-normalize-pathname
+ (sys-getenv "JD_ROOT")
+ :absolute #t :expand #t :canonicalize #t))
+
+(define jd:file-tree (cut jd:tree (jd:root)))
+
+;;; TRANSFORM DATA FROM FILESYSTEM TO SCHEME DATA
+
+(define file->jd:record
+ ;; 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))
+ (label (path-sans-extension raw-label))]
+ (make-jd:record jd:num label
+ (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.
+ ;; 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 path)]
+ [else => (.$ make-node (pa$ file->jd:record 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 root-path 'directory)
+ root-path))]
+ (make-node root-label (map map-fn jd:elts))))))
+
+
A => jd/meta.scm +153 -0
@@ 0,0 1,153 @@
+(define-module jd.meta
+ (use jd.filesystem)
+ (use jd.structures)
+ (use jd.trees)
+ (use parser.peg)
+ (export jd:meta-file-tree jd:meta-tree))
+
+(select-module jd.meta)
+
+;;;; This module defines a way to parse data from the document 00.01-index
+;;;; according to the following indent-based grammar:
+;;;; DOC := (\n*NODE)*
+;;;; NODE := NODESPEC(\n\t| DESC)*(\n\tNODE)*
+;;;; NODESPEC := JDNUM LABEL
+;;;; JDNUM := \d\d(.(\d)+)*
+;;;; LABEL = DESC := a string
+
+;;; GRAMMAR DEFINITION {{{
+
+(define jd-parser:num-unit
+ ;; parses a number unit; takes an optional parameter `root` that forces the
+ ;; length of the number to be equal to 2 if true
+ (lambda [:optional (root #f)]
+ ($let ([d (if root ($repeat ($. #[\d]) 2)
+ ($many ($. #[\d]) 2))])
+ ($return (x->integer (list->string d))))))
+
+(define jd-parser:number
+ ;; parses a valid JD number
+ ($lift (.$ (pa$ filter (complement (pa$ eq? #f))) list)
+ (jd-parser:num-unit #t)
+ ($optional ($seq ($. #\.) (jd-parser:num-unit)))))
+
+(define jd-parser:node-label
+ ;; parses a label
+ ($lift list->string
+ ($seq ($many ($. #[ \t\-_])) ($many1 ($. #[^\n])))))
+
+(define jd-parser:description-line
+ ;; Parses a line of description, i.e. "| something" -> "something"
+ ($lift list->string
+ ($seq ($. #\|) ($. #\space) ($many1 ($. #[^\n])))))
+
+(define jd-parser:description
+ ;; Parses a block of description lines, where the first line is the short
+ ;; description and the remain lines make the long description.
+ ($lift (.$ (lambda [ls] (list (car ls) (string-join (cadr ls) " "))) list)
+ jd-parser:description-line
+ ($many ($try ($seq ($. #\nl) jd-parser:description-line)))))
+
+
+(define jd-parser:node-header
+ ;; parses a node-header corresponding to NODESPEC above
+ ($lift list
+ jd-parser:number
+ jd-parser:node-label))
+
+(define jd-parser:node-list
+ ;; parses a list of nodes, usually children of a given node or top-level
+ ;; nodes.
+ ($lazy ($many ($between ($many ($. #\nl)) jd-parser:node ($many ($. #\nl))))))
+
+(define jd-parser:node-content
+ ;; parses the content of a node, that is the description thereof and its
+ ;; children.
+ ($lift list
+ ($optional jd-parser:description)
+ ($optional ($seq ($many ($. #\nl)) jd-parser:node-list))))
+
+
+(define jd-parser:node
+ ;; parses a whole node with all its attributes and children.
+ ;; Returns a jd:node with label jd:record having one jd:record-instance of
+ ;; type 'meta.
+ ($let [[node-header jd-parser:node-header]
+ [node-content ($optional ($between ($string "\nI")
+ jd-parser:node-content
+ ($or ($try ($seq ($many ($. #\nl)) ($. #\D)))
+ ($eos))))]]
+ (let* [[label (cadr node-header)]
+ [numspec (car node-header)]
+ [instance (make-jd:record-instance 'meta label)]]
+ (if node-content
+ (let* [[desc-list (car node-content)]
+ [sh-desc (and desc-list (car desc-list))]
+ [lg-desc (and desc-list (cadr desc-list))]
+ [children (cadr node-content)]
+ [record (make-jd:record numspec label
+ (list instance)
+ sh-desc lg-desc)]]
+ ($return (make-node record children)))
+ ($return (make-node (make-jd:record numspec label (list instance) #f #f)))))))
+
+;;; }}}
+
+;;; DECONTEXTUALISE THE GRAMMAR {{{
+;;; Instead of tabs, we track where the indentation increases or decreases by
+;;; deleting all leading whitespace and prepending an I when indentation
+;;; increases, and a D when it decreases. This transforms the above
+;;; context-dependent grammar into an independent one.
+
+(define jd-parser:ilevel+rest
+ ;; returns the indent level based on the formula space = 1, tab = 2 together
+ ;; with the remainder of the line.
+ (lambda [line]
+ (let [(head (string-ref line 0))
+ (rest (substring line 1 (string-length line)))]
+ (case head
+ ((#\space) (receive (ident str) (jd-parser:ilevel+rest rest)
+ (values (+ 1 ident) str)))
+ ((#\tab) (receive (ident str) (jd-parser:ilevel+rest rest)
+ (values (+ 2 ident) str)))
+ (else (values 0 line))))))
+
+(define jd-parser:decontextualise-identation-proc
+ ;; Takes a line and the current indentation level and writes to the default
+ ;; output the decontextualised line
+ (lambda [line cur-indent]
+ (receive (ident str) (jd-parser:ilevel+rest line)
+ (let* [(diff (/ (abs (- cur-indent ident)) 2))
+ [identsymbol (case (compare cur-indent ident)
+ [(-1) (make-string diff #\I)]
+ [(0) ""]
+ [(1) (make-string diff #\D)])]]
+ (display identsymbol)
+ (display str)
+ (newline)
+ ident))))
+
+(define jd-parser:decontextualise-identation
+ ;; deconxtualises an indented file.
+ (lambda [filepath]
+ (let1 result (with-output-to-string
+ (cut with-input-from-file filepath
+ (cut generator-fold
+ jd-parser:decontextualise-identation-proc
+ 0 read-line)))
+ result)))
+
+;;; }}}
+
+(define jd:meta-tree
+ (lambda []
+ (let1 meta-path (string-join (list (jd:root)
+ "00-meta"
+ "00.01-index") "/")
+ (jd:meta-file-tree meta-path))))
+
+(define jd:meta-file-tree
+ (lambda [filepath]
+ (let1 deindented (jd-parser:decontextualise-identation
+ (sys-normalize-pathname filepath))
+ (make-node "index" (peg-parse-string jd-parser:node-list deindented)))))
A => jd/notmuch.scm +37 -0
@@ 0,0 1,37 @@
+(define-module jd.notmuch
+ (use jd.structures)
+ (use jd.util)
+ (use jd.trees)
+ (use gauche.process)
+ (export jd:notmuch-records jd:notmuch-tree))
+
+(select-module jd.notmuch)
+
+
+(define jd:notmuch-tags
+ (lambda []
+ (let* [(nm-cmd '("notmuch" "search"
+ "--format=sexp" "--output=tags" "*"))
+ (nm-output-port (values-ref (open-input-process-port nm-cmd) 0))
+ (nm-tags (read nm-output-port))]
+ (filter johnny? nm-tags))))
+
+(define jd:notmuch-records
+ (lambda [] (map nm-tag->jd:record (jd:notmuch-tags))))
+
+(define nm-tag->jd:record
+ ;; converts a notmuch tag to a jd:record
+ (lambda (tag)
+ (let-values [((raw-id label) (string-scan tag #\- 'both))]
+ (let [(numspec (numstring->numspec raw-id))]
+ (make-jd:record numspec label
+ ($ list $ make-jd:record-instance 'nm-tag tag)
+ #f #f)))))
+
+
+(define jd:notmuch-tree
+ (lambda []
+ (let [(root (make-node "notmuch-tags"))
+ (nm-records (jd:notmuch-records))]
+ (fold-left jd:insert-in-tree root nm-records))))
+
A => jd/structures.scm +101 -0
@@ 0,0 1,101 @@
+(define-module jd.structures
+ (use gauche.record)
+ (export-all))
+
+(select-module jd.structures)
+;;; JD-RECORDS {{{
+
+(define-record-type jd:record #t #t
+ ;; number is a numspec: list of integers representing the address
+ ;; label: convenience name for the numspec
+ ;; instances: a list of where the number is used. Must be instances of
+ ;; jd:record-instance.
+ ;; short-desc: a short description
+ ;; long-desc: a long description
+ number label instances short-desc long-desc)
+
+(define-record-type jd:record-instance #t #t
+ ;; type: symbol among directory, regular, nm-tag
+ ;; data: depending on the type, where to find this number
+ type data)
+
+(define jd:record-append
+ ;; adds the instances of two jd:records IF their numbers matches.
+ ;; keeps only the data from the first record
+ (lambda (jdr1 jdr2)
+ (assume (equal? (jd:record-number jdr1) (jd:record-number jdr2)))
+ (let [(num (jd:record-number jdr1))
+ (label (jd:record-label jdr1))
+ (instances (jd:record-instances jdr1))
+ (instances2 (jd:record-instances jdr2))
+ (sh-desc (jd:record-short-desc jdr1))
+ (lg-desc (jd:record-long-desc jdr1))]
+ (make-jd:record num label
+ (append instances instances2)
+ sh-desc lg-desc))))
+
+(define jd:area
+ ;; returns the area of a numspec
+ (lambda (num-spec)
+ ($ * 10 $ (cut quotient <> 10) $ car num-spec)))
+
+(define jd:category
+ ;; returns the category of a numspec
+ car)
+
+(define jd:area? (lambda (numspec) (equal? numspec ($ list $ jd:area numspec))))
+(define jd:category? (lambda (numspec) (= 1 (length numspec))))
+(define jd:is-child?
+ (lambda [ns-parent ns-child]
+ (and (= 1 (length ns-parent))
+ (case (length ns-child)
+ [(1) (and (jd:area? ns-parent)
+ (not (= (jd:area ns-child) (car ns-child)))
+ (= (jd:area ns-child) (car ns-parent)))]
+ [(2) (cond
+ [(jd:area? ns-parent) (= (jd:area ns-child) (car ns-parent))]
+ [(jd:category? ns-parent) (= (car ns-child) (car ns-parent))]
+ [else #f])]))))
+(define jd:is-direct-child?
+ (lambda [ns-parent ns-child]
+ (and (jd:is-child? ns-parent ns-child)
+ (or (and (jd:area? ns-parent) (jd:category? ns-child))
+ (and (jd:category? ns-parent)
+ (= 2 (length ns-child))
+ (= (car ns-parent) (car ns-child)))))))
+
+(define jd:path
+ ;; returns a path to go to the numspec in terms of numbers.
+ (lambda (numspec)
+ (cond [(and ($ = 1 $ length numspec)
+ ($ = 0 $ mod (car numspec) 10))
+ numspec]
+ [($ = 1 $ length numspec)
+ (list (jd:area numspec) (jd:category numspec))]
+ [else
+ (append ($ jd:path
+ $ list
+ $ car numspec)
+ ($ list
+ $ cadr numspec))])))
+
+
+(define jd:record->string
+ ;; provides a string reprenstation for a record
+ (lambda (record :optional (verbose #f))
+ (let [(id (string-join
+ (map (pa$ format "~2,,,'0,,@s") (jd:record-number record))
+ "."))
+ (type-string (string-join (map (lambda (inst)
+ (case (jd:record-instance-type inst)
+ ['directory "D"]
+ ['regular "F"]
+ ['nm-tag "@"]
+ ['tw-project "T"]
+ ['meta "M"]))
+ (jd:record-instances record))
+ ""))]
+ (string-join (list id (jd:record-label record) type-string
+ (or (jd:record-short-desc record) ""))))))
+
+
A => jd/taskwarrior.scm +31 -0
@@ 0,0 1,31 @@
+(define-module jd.taskwarrior
+ (use jd.structures)
+ (use jd.util)
+ (use gauche.process)
+ (export jd:taskwarrior-projects jd:taskwarrior-nodes))
+
+(select-module jd.taskwarrior)
+
+(define jd:taskwarrior-projects
+ (lambda []
+ (let* [(tw-cmd '("task" "_projects"))
+ (tw-output-port (values-ref (open-input-process-port tw-cmd) 0))
+ (tw-projects (port->string-list tw-output-port))]
+ (filter johnny-tw? tw-projects))))
+
+(define tw-project->jd:record
+ ;; converts a taskwarrior project to a jd:record
+ (lambda [project]
+ (let-values [((raw-id label) (string-scan project #\_ 'both))]
+ (let* [(numspec_temp (numstring->numspec raw-id))
+ (numspec (if (and (= (length numspec_temp) 2)
+ (= 0 (cadr numspec_temp)))
+ (list (car numspec_temp))
+ numspec_temp))]
+ (make-jd:record numspec label
+ ($ list $ make-jd:record-instance
+ 'tw-project project)
+ #f #f)))))
+
+(define jd:taskwarrior-nodes
+ (cut map tw-project->jd:record (jd:taskwarrior-projects)))
A => jd/trees.scm +197 -0
@@ 0,0 1,197 @@
+(define-module jd.trees
+ (use gauche.record)
+ (use scheme.list)
+ (use jd.structures)
+ (export node? make-node node-label node-children leaf?
+ map-tree fold-tree
+ jd:insert-in-tree jd:fuse-trees jd:print-tree))
+
+(select-module jd.trees)
+
+;;; Tree/Forest/Node data structure {{{
+
+(define-record-type node -make-node #t
+ label children)
+
+(define make-node
+ (lambda (label :optional (children '()))
+ (-make-node label children)))
+
+(define leaf?
+ (lambda (node)
+ (null? (node-children node))))
+
+;;; }}}
+
+;;; Tree functions {{{
+
+(define map-tree
+ ;; works for trees defined using the node record
+ (lambda (fn tree)
+ (let [(label (node-label tree))
+ (children (node-children tree))]
+ (make-node (fn label) (map (pa$ map-tree fn) children)))))
+
+(define fold-tree
+ ;; fn-concat (list): function that combines the node and the result from
+ ;; children.
+ ;; fn-node (acc node): function that transforms the node into the desired
+ ;; type
+ ;; fn-acc (acc node): function that takes the accumulator onto the next step
+ ;; acc : the base value for the accumulator
+ ;; tree : the tree on which to fold
+ ;; default: the default value when the tree is empty
+ (lambda (fn-concat fn-node fn-acc acc tree)
+ (let [(label (node-label tree))
+ (children (node-children tree))]
+ (fn-concat (fn-node acc label)
+ (if (null? children) '()
+ (map (pa$ fold-tree fn-concat
+ fn-node
+ fn-acc
+ (fn-acc acc label))
+ children))))))
+
+;;; }}}
+
+;;; Trees whose labels are jd:records {{{
+
+(define jd:part-ordered-node-list
+ (let [(numspec> (lambda (ns node)
+ (> (compare ns
+ (jd:record-number (node-label node)))
+ 0)))
+ (numspec>= (lambda (ns node)
+ (>= (compare ns
+ (jd:record-number (node-label node)))
+ 0)))]
+ (lambda (numspec ls)
+ (let*-values [((start right) (span (pa$ numspec> numspec) ls))
+ ((middle end) (span (pa$ numspec>= numspec) right))]
+ (values start middle end)))))
+
+(define jd:insert-in-tree
+ (lambda [tree record]
+ (let* [(num-rec (jd:record-number record))
+ (label (node-label tree))
+ (children (node-children tree))
+ (node-num (when (jd:record? label) (jd:record-number label)))]
+ (cond
+ [(equal? num-rec node-num)
+ (make-node (jd:record-append label record) children)]
+ [(or (undefined? node-num) ; we're at the root of
+ (and (= 1 (length node-num))
+ (jd:is-child? node-num num-rec)))
+ (let-values [((st mid end)
+ (jd:part-ordered-node-list num-rec children))]
+ (if (null? mid)
+ (if (or (and (undefined? node-num)
+ (jd:area? num-rec))
+ (and ($ not $ undefined? node-num)
+ (jd:is-direct-child? node-num num-rec)))
+ (make-node label
+ (append st
+ (list (make-node record))
+ end))
+ (let1 last (unless (null? st) (last st))
+ (when (and (not (undefined? last))
+ (jd:is-child? ($ jd:record-number
+ $ node-label last)
+ num-rec))
+ (let1 maybe-result (jd:insert-in-tree last record)
+ (unless (undefined? maybe-result)
+ (make-node label
+ (append (drop-right st 1)
+ `(,maybe-result)
+ end)))))))
+ (let1 result (jd:insert-in-tree (car mid) record)
+ (unless (undefined? result)
+ (make-node label
+ (append st `(,result) end))))))]))))
+
+(define jd:fuse-ordered-node-list
+ ;; We assume that we're at the same level each time
+ (lambda [list1 list2]
+ (cond
+ [(null? list1) list2]
+ [(null? list2) list1]
+ [else
+ (let* [(head1 (car list1))
+ (head2 (car list2))
+ (label1 (node-label head1))
+ (label2 (node-label head2))
+ (num1 (jd:record-number label1))
+ (num2 (jd:record-number label2))]
+ (case (compare num1 num2)
+ ((-1) (cons head1 (jd:fuse-ordered-node-list (cdr list1) list2)))
+ ((1) (cons head2 (jd:fuse-ordered-node-list list1
+ (cdr list2))))
+ ((0) (cons (jd:fuse-trees head1 head2)
+ (jd:fuse-ordered-node-list (cdr list1)
+ (cdr list2))))))])))
+
+
+(define jd:fuse-trees
+ (lambda [tree1 tree2]
+ (let* [(label1 (node-label tree1))
+ (label2 (node-label tree2))
+ (children1 (node-children tree1))
+ (children2 (node-children tree2))
+ (new-children (jd:fuse-ordered-node-list children1 children2))
+ (new-label (if (and (jd:record? label1) (jd:record? label2))
+ (jd:record-append label1 label2)
+ label1))]
+ (make-node new-label new-children))))
+
+(define -node-numspec (lambda (node) (jd:record-number (label node))))
+(define jd:get-closest
+ ; gives a list (pointer) the closest to the given numspec.
+ ; pushable.
+ (lambda [num-spec tree]
+ (let [(label (node-label tree))
+ (children (node-children tree))]
+ (if (null? children) tree
+ (let [(remainder (drop-until
+ (lambda (node)
+ (let* [(label (node-label node))
+ (n-index (-node-numspec label))]
+ (or (list>=? n-index num-spec)
+ ; general case
+ (and (jd:category? n-index)
+ (or (= (jd:area num-spec)
+ (jd:area n-index)
+ (car n-index))
+ ; top level case
+ (= (car n-index)
+ (car num-spec)))))))
+ ; second-level case
+ children))]
+ (if (null? remainder)
+ (values remainder #f)
+ (let* [(head (car remainder))
+ (head-label (node-label head))
+ (head-index (-node-numspec head-label))
+ (comp (compare num-spec head-index))]
+ (cond
+ [(= 0 comp) (values head #t)]
+ [(equal? ($ list $ jd:area num-spec) head-index)
+ (jd:get-closest num-spec (node-children head))]
+ [(equal? ($ list $ jd:category num-spec) head-index)
+ (jd:get-closest num-spec (node-children head))]
+ [else (values remainder #f)]))))))))
+
+(define jd:print-tree
+ ;; returns a formatted string representing a jd:tree
+ (lambda (tree :optional (verbose #f))
+ (fold-tree
+ (lambda [first ls]
+ (string-join (cons first ls) "\n"))
+ (lambda (acc label)
+ (string-append acc (if (string? label) label
+ (jd:record->string label verbose))))
+ (lambda (acc node)
+ (string-append " " acc))
+ ""
+ tree)))
+
+
A => jd/util.scm +39 -0
@@ 0,0 1,39 @@
+(define-module jd.util
+ (use scheme.regex)
+ (use scheme.list)
+ (export drop-until list>=? johnny? johnny-tw? numstring->numspec))
+
+
+(select-module jd.util)
+
+;;; LIST FUNCTIONS {{{
+
+(define drop-until (lambda (pred list) (drop-while (complement pred) list)))
+
+(define list>=? (lambda (ns1 ns2) (> (compare ns1 ns2) -1)))
+
+;;; }}}
+
+;;; JD CONVENIENCE FUNCTIONS {{{
+
+(define mk-johnny-regexp
+ ;; makes a regexp matching a valid JD identifier, with `sep` as the separator
+ ;; between the number and the label
+ (let1 lr-regexp (map regexp->string (list #/\d{2}(\.\d+)*/ #/.+/))
+ (lambda [sep]
+ ($ string->regexp $ string-join lr-regexp sep))))
+
+(define johnny?
+ ;; true if the provided string is a valid JD identifier
+ (pa$ regexp-matches? (mk-johnny-regexp "-")))
+
+(define johnny-tw?
+ ;; special format for taskwarrior JD identifiers
+ (pa$ regexp-matches? (mk-johnny-regexp "_")))
+
+(define numstring->numspec
+ ;; converts a string "YY.XX" to a list of numbers (YY XX)
+ (lambda (numstring)
+ ($ map string->number $ string-split numstring #\.)))
+
+;;; }}}
A => jd/zsh.scm +32 -0
@@ 0,0 1,32 @@
+(define-module jd.zsh
+ (use jd.trees)
+ (use jd.structures)
+ (export jd:generate-zsh-completions))
+
+(select-module jd.zsh)
+
+
+(define num-format
+ (lambda [numspec]
+ (string-join (map (pa$ format "~2,,,'0,,@s") numspec) ".")))
+
+(define jd:generate-zsh-completions
+ (lambda [jd-file-tree]
+ (fold-tree
+ (lambda [fst ls]
+ (let1 purged (filter (complement (pa$ equal? "")) (cons fst ls))
+ (string-join purged " ")))
+ (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 "~a:~a" num-string rec-label))))
+ (lambda [_ _] "")
+ ""
+ jd-file-tree)))
+
+
M johnny.scm +9 -632
@@ 1,647 1,24 @@
-#!/bin/env gauche
+#!/bin/env -S gauche -I.
;;;; johnny.scm
;;;; Module to deal with Johnny.Decimal related operations.
;;;; Copyright xaltsc 2021
-(use file.util)
-(use scheme.regex)
-(use scheme.list)
-(use gauche.record)
(use gauche.process)
-(use parser.peg)
-
-(define drop-until (lambda (pred list) (drop-while (.$ not pred) list)))
-(define list>=? (lambda (ns1 ns2) (> (compare ns1 ns2) -1)))
-
-;;; Tree functions {{{
-
-(define old-map-tree
- ;; recursively maps a function into a tree obeying a grammar similar to the
- ;; one defined for the function jd:tree.
- (lambda (function tree)
- (map (lambda (elt) (if (list? elt) (map-tree function elt) (function elt)))
- tree)))
-
-(define map-tree
- ;; works for trees defined using the node record
- (lambda (fn tree)
- (let [(label (node-label tree))
- (children (node-children tree))]
- (make-node (fn label) (map (pa$ map-tree fn) children)))))
-
-(define old-fold-tree
- (lambda (fn-concat fn-node fn-acc acc tree default)
- ;; fn-concat (list): function that combines the node and the result from
- ;; children.
- ;; fn-node (acc node): function that transforms the node into the desired
- ;; type
- ;; fn-acc (acc node): function that takes the accumulator onto the next step
- ;; acc : the base value for the accumulator
- ;; tree : the tree on which to fold
- ;; default: the default value when the tree is empty
- (if (null? tree) default
- (fn-concat
- (let [(node (car tree))]
- (apply list (fn-node acc node)
- (map (cut fold-tree
- fn-concat
- fn-node
- fn-acc
- (fn-acc acc node)
- <>
- default)
- (cadr tree))))))))
-
-(define fold-tree
- (lambda (fn-concat fn-node fn-acc acc tree)
- (let [(label (node-label tree))
- (children (node-children tree))]
- (fn-concat (fn-node acc label)
- (if (null? children) '()
- (map (pa$ fold-tree fn-concat
- fn-node
- fn-acc
- (fn-acc acc label))
- children))))))
-
-(define-record-type node -make-node #t
- label children)
-
-(define make-node
- (lambda (label :optional (children '()))
- (-make-node label children)))
-
-(define leaf?
- (lambda (node)
- (null? (node-children node))))
-
-;;; }}}
-
-;;; JD CONVENIENCE FUNCTIONS {{{
-
-(define johnny?
- ;; true if the provided string is a valid JD identifier
- (pa$ regexp-matches? #/\d{2}(\.\d+)*-.+/))
-
-(define tw:johnny?
- ;; special format for taskwarrior JD identifiers
- (pa$ regexp-matches? #/\d{2}(\.\d+)*_.+/))
-
-(define numstring->numspec
- ;; converts a string "YY.XX" to a list of numbers (YY XX)
- (lambda (numstring)
- ($ map string->number $ string-split numstring #\.)))
-
-(define jd:print-tree
- ;; returns a formatted string representing a jd:tree
- (lambda (tree :optional (verbose #f))
- (fold-tree
- (lambda [first ls]
- (string-join (cons first ls) "\n"))
- (lambda (acc label)
- (string-append acc (if (string? label) label
- (jd:record->string label verbose))))
- (lambda (acc node)
- (string-append " " acc))
- ""
- tree)))
-
-
-;;; }}}
-
-;;; JD-RECORDS {{{
-
-(define-record-type jd:record #t #t
- ;; number is a numspec: list of integers representing the address
- ;; label: convenience name for the numspec
- ;; instances: a list of where the number is used. Must be instances of
- ;; jd:record-instance.
- ;; short-desc: a short description
- ;; long-desc: a long description
- number label instances short-desc long-desc)
-
-(define-record-type jd:record-instance #t #t
- ;; type: symbol among directory, regular, nm-tag
- ;; data: depending on the type, where to find this number
- type data)
-
-(define jd:record-append
- ;; adds the instances of two jd:records IF their numbers matches.
- ;; keeps only the data from the first record
- (lambda (jdr1 jdr2)
- (assume (equal? (jd:record-number jdr1) (jd:record-number jdr2)))
- (let [(num (jd:record-number jdr1))
- (label (jd:record-label jdr1))
- (instances (jd:record-instances jdr1))
- (instances2 (jd:record-instances jdr2))
- (sh-desc (jd:record-short-desc jdr1))
- (lg-desc (jd:record-long-desc jdr1))]
- (make-jd:record num label
- (append instances instances2)
- sh-desc lg-desc))))
-
-(define jd:area
- ;; returns the area of a numspec
- (lambda (num-spec)
- ($ * 10 $ (cut quotient <> 10) $ car num-spec)))
-
-(define jd:category
- ;; returns the category of a numspec
- (lambda (num-spec)
- (car num-spec)))
-
-(define jd:area? (lambda (numspec) (equal? numspec ($ list $ jd:area numspec))))
-(define jd:category? (lambda (numspec) (= 1 (length numspec))))
-(define jd:is-child?
- (lambda [ns-parent ns-child]
- (and (= 1 (length ns-parent))
- (case (length ns-child)
- [(1) (and (jd:area? ns-parent)
- (not (= (jd:area ns-child) (car ns-child)))
- (= (jd:area ns-child) (car ns-parent)))]
- [(2) (cond
- [(jd:area? ns-parent) (= (jd:area ns-child) (car ns-parent))]
- [(jd:category? ns-parent) (= (car ns-child) (car ns-parent))]
- [else #f])]))))
-(define jd:is-direct-child?
- (lambda [ns-parent ns-child]
- (and (jd:is-child? ns-parent ns-child)
- (or (and (jd:area? ns-parent) (jd:category? ns-child))
- (and (jd:category? ns-parent)
- (= 2 (length ns-child))
- (= (car ns-parent) (car ns-child)))))))
-
-(define jd:path
- ;; returns a path to go to the numspec in terms of numbers.
- (lambda (numspec)
- (cond [(and ($ = 1 $ length numspec)
- ($ = 0 $ mod (car numspec) 10))
- numspec]
- [($ = 1 $ length numspec)
- (list (jd:area numspec) (jd:category numspec))]
- [else
- (append ($ jd:path
- $ list
- $ car numspec)
- ($ list
- $ cadr numspec))])))
-
-
-(define jd:record->string
- ;; provides a string reprenstation for a record
- (lambda (record :optional (verbose #f))
- (let [(id (string-join
- (map (pa$ format "~2,,,'0,,@s") (jd:record-number record))
- "."))
- (type-string (string-join (map (lambda (inst)
- (case (jd:record-instance-type inst)
- ['directory "D"]
- ['regular "F"]
- ['nm-tag "@"]
- ['tw-project "T"]
- ['meta "M"]))
- (jd:record-instances record))
- ""))]
- (string-join (list id (jd:record-label record) type-string
- (or (jd:record-short-desc record) ""))))))
-
-(define -node-numspec (lambda (node) (jd:record-number (label node))))
-(define jd:get-closest
- ; gives a list (pointer) the closest to the given numspec.
- ; pushable.
- (lambda [num-spec tree]
- (let [(label (node-label tree))
- (children (node-children tree))]
- (if (null? children) tree
- (let [(remainder (drop-until
- (lambda (node)
- (let* [(label (node-label node))
- (n-index (-node-numspec label))]
- (or (list>=? n-index num-spec)
- ; general case
- (and (jd:category? n-index)
- (or (= (jd:area num-spec)
- (jd:area n-index)
- (car n-index))
- ; top level case
- (= (car n-index)
- (car num-spec)))))))
- ; second-level case
- children))]
- (if (null? remainder)
- (values remainder #f)
- (let* [(head (car remainder))
- (head-label (node-label head))
- (head-index (-node-numspec head-label))
- (comp (compare num-spec head-index))]
- (cond
- [(= 0 comp) (values head #t)]
- [(equal? ($ list $ jd:area num-spec) head-index)
- (jd:get-closest num-spec (node-children head))]
- [(equal? ($ list $ jd:category num-spec) head-index)
- (jd:get-closest num-spec (node-children head))]
- [else (values remainder #f)]))))))))
-
-;;; }}}
-
-;;; INTERACTION BETWEEN DATA AND JD-OBJECTS
-
-(define file->jd:record
- ;; 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))
- (label (path-sans-extension raw-label))]
- (make-jd:record jd:num label
- (list (make-jd:record-instance type path))
- #f #f))))))
-
-(define nm-tag->jd:record
- ;; converts a notmuch tag to a jd:record
- (lambda (tag)
- (let-values [((raw-id label) (string-scan tag #\- 'both))]
- (let [(numspec (numstring->numspec raw-id))]
- (make-jd:record numspec label
- ($ list $ make-jd:record-instance 'nm-tag tag)
- #f #f)))))
-
-(define tw-project->jd:record
- ;; converts a taskwarrior project to a jd:record
- (lambda [project]
- (let-values [((raw-id label) (string-scan project #\_ 'both))]
- (let* [(numspec_temp (numstring->numspec raw-id))
- (numspec (if (and (= (length numspec_temp) 2)
- (= 0 (cadr numspec_temp)))
- (list (car numspec_temp))
- numspec_temp))]
- (make-jd:record numspec label
- ($ list $ make-jd:record-instance
- 'tw-project project)
- #f #f)))))
-
+(use jd.zsh)
+(use jd.filesystem)
-;(define label car)
-;(define children cadr)
-
-(define old-jd:tree
- ;; 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.
- (lambda (root)
- (let [(jd:elts (directory-list root
- :add-path? #t
- :children? #t
- :filter johnny?))
- (root-record (if (johnny? (sys-basename root))
- (file->jd:record root 'directory)
- root))]
- (if (null? jd:elts) (list root-record '())
- (list root-record
- (map (lambda (path)
- (let [(filetype (file-type path :follow-link? #t))]
- (cond [(eq? filetype 'regular)
- (list (file->jd:record path 'regular) '())]
- [(eq? filetype 'directory)
- (jd:tree path)])))
- jd:elts))))))
-(define jd:tree
- (let [(map-fn (lambda (path)
- (case (file-type path :follow-link? #t)
- [(directory) (jd:tree path)]
- [else => (.$ make-node (pa$ file->jd:record 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 root-path 'directory)
- root-path))]
- (make-node root-label (map map-fn jd:elts))))))
-
-;;; DATA FROM SYSTEM {{{
-
-(define jd:root
- (sys-normalize-pathname
- (sys-getenv "JD_ROOT")
- :absolute #t :expand #t :canonicalize #t))
-
-(define jd:docs (jd:tree jd:root))
-
-(define jd:notmuch-tags
- (let* [(nm-cmd '("notmuch" "search"
- "--format=sexp" "--output=tags" "*"))
- (nm-output-port (values-ref (open-input-process-port nm-cmd) 0))
- (nm-tags (read nm-output-port))]
- (filter johnny? nm-tags)))
-
-(define jd:taskwarrior-projects
- (let* [(tw-cmd '("task" "_projects"))
- (tw-output-port (values-ref (open-input-process-port tw-cmd) 0))
- (tw-projects (port->string-list tw-output-port))]
- (filter tw:johnny? tw-projects)))
-
-
-;;; }}}
-
-(define jd:part-ordered-node-list
- (let [(numspec> (lambda (ns node)
- (> (compare ns
- (jd:record-number (node-label node)))
- 0)))
- (numspec>= (lambda (ns node)
- (>= (compare ns
- (jd:record-number (node-label node)))
- 0)))]
- (lambda (numspec ls)
- (let*-values [((start right) (span (pa$ numspec> numspec) ls))
- ((middle end) (span (pa$ numspec>= numspec) right))]
- (values start middle end)))))
-
-(define jd:old-insert-in-tree
- ;; insert a record in a tree
- ;; if it isn't possible (most like for reasons of uncompatible depth),
- ;; returns undefined.
- ;; This function allocates a new list in most cases.
- (lambda (tree record)
- (let [(num (jd:record-number record))]
- (let*-values [((start middle end) (jd:part-tree num tree))
- ((last-start ns-mid)
- (values (unless (null? start)
- (last start))
- (unless (null? middle)
- ($ jd:record-number $ label $ car middle))))]
- (cond
- [(undefined? ns-mid)
- ;; In this case, we figure whether the record should be inserted in
- ;; the middle or in the children of the last record of the start
- ;; list.
- (if (undefined? last-start)
- ;; trivial case, but need to check depth
- (cond [(null? end) `((,record ()))]
- ;; the tree is empty
- [(= ($ length $ jd:record-number record)
- ($ length $ jd:record-number $ label $ car end))
- ;; check record is of the right depth
- (cons `((,record ())) end)])
- (let* [(ls-num ($ jd:record-number $ label last-start))
- (ls-cat (car ls-num))]
- (cond
- [(= (length ls-num) (length num) 2)
- ;; the depths agree
- (append start (list `(,record ()) end))]
- [(= (length ls-num) (length num) 1)
- ;; the depths agree
- (if (= ls-cat (jd:area num))
- (let1 inside-tree (jd:insert-in-tree
- (children last-start)
- record)
- (unless (undefined? inside-tree)
- (append (drop-right start 1)
- `((,(label last-start) ,inside-tree))
- end)))
- (append start (list `(,record ()) end)))]
- [(and (= (length ls-num) 1) (= (length num) 2)
- (or (= ls-cat (jd:area num))
- (= ls-cat (jd:category num)))
- ;; the record should be a descendent of the last element of
- ;; start
- (let1 inside-tree (jd:insert-in-tree
- (children last-start)
- record)
- (unless (undefined? inside-tree)
- (append (drop-right start 1)
- `((,(label last-start) ,inside-tree))
- end))))])))]
- [(equal? num ns-mid)
- ;; in this case, the record is another instance of an already
- ;; existing record.
- (append start
- (list
- `(,(jd:record-append ($ label $ car middle) record) ()))
- end)]
- [else (undefined)])))))
+;(define jd:full-tree
+; (let* [(tw-records (map tw-project->jd:record jd:taskwarrior-projects))
+; (fused0 (jd:fuse-trees jd:docs jd:notmuch-tree))
+; (fused (jd:fuse-trees jd:index-tree fused0))
+; (fold-left jd:insert-in-tree fused tw-records))
-(define jd:insert-in-tree
- (lambda [tree record]
- (let* [(num-rec (jd:record-number record))
- (label (node-label tree))
- (children (node-children tree))
- (node-num (when (jd:record? label) (jd:record-number label)))]
- (cond
- [(equal? num-rec node-num)
- (make-node (jd:record-append label record) children)]
- [(or (undefined? node-num) ; we're at the root of
- (and (= 1 (length node-num))
- (jd:is-child? node-num num-rec)))
- (let-values [((st mid end)
- (jd:part-ordered-node-list num-rec children))]
- (if (null? mid)
- (if (or (and (undefined? node-num)
- (jd:area? num-rec))
- (and ($ not $ undefined? node-num)
- (jd:is-direct-child? node-num num-rec)))
- (make-node label
- (append st
- (list (make-node record))
- end))
- (let1 last (unless (null? st) (last st))
- (when (and (not (undefined? last))
- (jd:is-child? ($ jd:record-number
- $ node-label last)
- num-rec))
- (let1 maybe-result (jd:insert-in-tree last record)
- (unless (undefined? maybe-result)
- (make-node label
- (append (drop-right st 1)
- `(,maybe-result)
- end)))))))
- (let1 result (jd:insert-in-tree (car mid) record)
- (unless (undefined? result)
- (make-node label
- (append st `(,result) end))))))]))))
-(define jd:notmuch-tree
- (let [(root (make-node "notmuch-tags"))
- (nm-records (map nm-tag->jd:record jd:notmuch-tags))]
- (fold-left jd:insert-in-tree root nm-records)))
-
-
-(define jd:fuse-ordered-node-list
- ;; We assume that we're at the same level each time
- (lambda [list1 list2]
- (cond
- [(null? list1) list2]
- [(null? list2) list1]
- [else
- (let* [(head1 (car list1))
- (head2 (car list2))
- (label1 (node-label head1))
- (label2 (node-label head2))
- (num1 (jd:record-number label1))
- (num2 (jd:record-number label2))]
- (case (compare num1 num2)
- ((-1) (cons head1 (jd:fuse-ordered-node-list (cdr list1) list2)))
- ((1) (cons head2 (jd:fuse-ordered-node-list list1
- (cdr list2))))
- ((0) (cons (jd:fuse-trees head1 head2)
- (jd:fuse-ordered-node-list (cdr list1)
- (cdr list2))))))])))
-
-
-(define jd:fuse-trees
- (lambda [tree1 tree2]
- (let* [(label1 (node-label tree1))
- (label2 (node-label tree2))
- (children1 (node-children tree1))
- (children2 (node-children tree2))
- (new-children (jd:fuse-ordered-node-list children1 children2))
- (new-label (if (and (jd:record? label1) (jd:record? label2))
- (jd:record-append label1 label2)
- label1))]
- (make-node new-label new-children))))
-
-(define jd:generate-zsh-completions
- (let [(num-format
- (lambda [numspec]
- (string-join (map (pa$ format "~2,,,'0,,@s") numspec) ".")))]
- (lambda []
- (fold-tree
- (lambda [fst ls]
- (let1 purged (filter (complement (pa$ equal? "")) (cons fst ls))
- (string-join purged " ")))
- (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 "~a:~a" num-string rec-label))))
- (lambda [_ _] "")
- ""
- jd:docs))))
-
-;;; Parsing the document 00.00
-(define jd-parser:num-unit
- (lambda [:optional (root #f)]
- ($let ([d (if root ($repeat ($. #[\d]) 2)
- ($many ($. #[\d]) 2))])
- ($return (x->integer (list->string d))))))
-
-(define jd-parser:number
- ($lift (.$ (pa$ filter (complement (pa$ eq? #f))) list)
- (jd-parser:num-unit #t)
- ($optional ($seq ($. #\.) (jd-parser:num-unit)))))
-
-(define jd-parser:node-label
- ($lift list->string
- ($seq ($many ($. #[ \t\-_])) ($many1 ($. #[^\n])))))
-
-(define jd-parser:description-line
- ($lift list->string
- ($seq ($. #\|) ($. #\space) ($many1 ($. #[^\n])))))
-
-(define jd-parser:description
- ($lift (.$ (lambda [ls] (list (car ls) (string-join (cadr ls) " "))) list)
- jd-parser:description-line
- ($many ($try ($seq ($. #\nl) jd-parser:description-line)))))
-
-
-(define jd-parser:node-header
- ($lift list
- jd-parser:number
- jd-parser:node-label))
-
-(define jd-parser:node-list
- ($lazy ($many ($between ($many ($. #\nl)) jd-parser:node ($many ($. #\nl))))))
-
-(define jd-parser:node-content
- ($lift list
- ($optional jd-parser:description)
- ($optional ($seq ($many ($. #\nl)) jd-parser:node-list))))
-
-
-(define jd-parser:node
- ($let [[node-header jd-parser:node-header]
- [node-content ($optional ($between ($string "\nI")
- jd-parser:node-content
- ($or ($try ($seq ($many ($. #\nl)) ($. #\D)))
- ($eos))))]]
- (let* [[label (cadr node-header)]
- [numspec (car node-header)]
- [instance (make-jd:record-instance 'meta label)]]
- (if node-content
- (let* [[desc-list (car node-content)]
- [sh-desc (and desc-list (car desc-list))]
- [lg-desc (and desc-list (cadr desc-list))]
- [children (cadr node-content)]
- [record (make-jd:record numspec label
- (list instance)
- sh-desc lg-desc)]]
- ($return (make-node record children)))
- ($return (make-node (make-jd:record numspec label (list instance) #f #f)))))))
-
-(define jd-parser:ilevel+rest
- (lambda [line]
- (let [(head (string-ref line 0))
- (rest (substring line 1 (string-length line)))]
- (case head
- ((#\space) (receive (ident str) (jd-parser:ilevel+rest rest)
- (values (+ 1 ident) str)))
- ((#\tab) (receive (ident str) (jd-parser:ilevel+rest rest)
- (values (+ 2 ident) str)))
- (else (values 0 line))))))
-
-(define jd-parser:decontextualise-identation-proc
- (lambda [line cur-indent]
- (receive (ident str) (jd-parser:ilevel+rest line)
- (let* [(diff (/ (abs (- cur-indent ident)) 2))
- [identsymbol (case (compare cur-indent ident)
- [(-1) (make-string diff #\I)]
- [(0) ""]
- [(1) (make-string diff #\D)])]]
- (display identsymbol)
- (display str)
- (newline)
- ident))))
-
-(define jd-parser:decontextualise-identation
- (lambda [filepath]
- (let1 result (with-output-to-string
- (cut with-input-from-file filepath
- (cut generator-fold
- jd-parser:decontextualise-identation-proc
- 0 read-line)))
- result)))
-
-(define jd:index-tree
- (let1 deindented (jd-parser:decontextualise-identation
- (sys-normalize-pathname
- (string-join (list jd:root
- "00-meta"
- "00.01-index") "/")))
- (make-node "index" (peg-parse-string jd-parser:node-list deindented))))
-
-
-(define jd:full-tree
- (let* [(tw-records (map tw-project->jd:record jd:taskwarrior-projects))
- (fused0 (jd:fuse-trees jd:docs jd:notmuch-tree))
- (fused (jd:fuse-trees jd:index-tree fused0))]
- (fold-left jd:insert-in-tree fused tw-records)))
;;; MAIN FUNC
(define main
(lambda (args)
(let1 argv (cdr args)
(ecase ($ string->symbol $ car argv)
[(--complete)
- (format (current-output-port) "~a" (jd:generate-zsh-completions))
+ (format (current-output-port) "~a" (jd:generate-zsh-completions (jd:file-tree)))
0]))))