diff options
| -rwxr-xr-x | bin/tissue | 89 | ||||
| -rw-r--r-- | tissue/document.scm | 5 | ||||
| -rw-r--r-- | tissue/issue.scm | 137 | ||||
| -rw-r--r-- | tissue/web/static.scm | 9 |
4 files changed, 116 insertions, 124 deletions
diff --git a/bin/tissue b/bin/tissue index 2c739b3..3ee0565 100755 --- a/bin/tissue +++ b/bin/tissue @@ -99,57 +99,54 @@ Show the text of FILE. " (command-line-program))) ((file) - ;; Files may be renamed or deleted, but not committed. Therefore, - ;; only read the file if it exists. - (if (file-exists? file) - (call-with-input-file file - (lambda (port) - (port-transduce - (compose - ;; Detect preformatted text blocks. - (tfold (match-lambda* - (((pre? . _) line) - (cons (if (string-prefix? "```" line) - (not pre?) - pre?) - line))) - (cons #f #f)) - (tmap (lambda (pre?+line) - (match pre?+line - ((pre? . line) - (cond - ;; Print headlines in bold. - ((string-prefix? "#" line) - (display (colorize-string line 'BOLD))) - ;; Print lists in cyan. - ((string-prefix? "*" line) - (display (colorize-string line 'CYAN))) - ;; Print links in cyan, but only the actual - ;; link, and not the => prefix or the label. - ((string-match "^(=>[ \t]*)([^ ]*)([^\n]*)" line) - => (lambda (m) - (display (match:substring m 1)) - (display (colorize-string (match:substring m 2) 'CYAN)) - (display (match:substring m 3)))) - ;; Print preformatted text backticks in - ;; magenta. - ((string-prefix? "```" line) - (display (colorize-string line 'MAGENTA))) - (else - ;; If part of preformatted block, print in - ;; magenta. Else, print in default color. - (display (if pre? (colorize-string line 'MAGENTA) line)))))) - (newline)))) - (const #t) - get-line-dos-or-unix - port))) - (raise (issue-file-not-found-error file)))))) + (call-with-file-in-git (current-git-repository) file + (lambda (port) + (port-transduce + (compose + ;; Detect preformatted text blocks. + (tfold (match-lambda* + (((pre? . _) line) + (cons (if (string-prefix? "```" line) + (not pre?) + pre?) + line))) + (cons #f #f)) + (tmap (lambda (pre?+line) + (match pre?+line + ((pre? . line) + (cond + ;; Print headlines in bold. + ((string-prefix? "#" line) + (display (colorize-string line 'BOLD))) + ;; Print lists in cyan. + ((string-prefix? "*" line) + (display (colorize-string line 'CYAN))) + ;; Print links in cyan, but only the actual + ;; link, and not the => prefix or the label. + ((string-match "^(=>[ \t]*)([^ ]*)([^\n]*)" line) + => (lambda (m) + (display (match:substring m 1)) + (display (colorize-string (match:substring m 2) 'CYAN)) + (display (match:substring m 3)))) + ;; Print preformatted text backticks in + ;; magenta. + ((string-prefix? "```" line) + (display (colorize-string line 'MAGENTA))) + (else + ;; If part of preformatted block, print in + ;; magenta. Else, print in default color. + (display (if pre? (colorize-string line 'MAGENTA) line)))))) + (newline)))) + (const #t) + get-line-dos-or-unix + port)))))) (define load-config (memoize-thunk (lambda () "Load configuration and return <tissue-configuration> object." - (load (canonicalize-path "tissue.scm"))))) + (call-with-file-in-git (current-git-repository) "tissue.scm" + (compose eval-string get-string-all))))) (define tissue-repl (match-lambda* diff --git a/tissue/document.scm b/tissue/document.scm index 1ee55cf..e46e055 100644 --- a/tissue/document.scm +++ b/tissue/document.scm @@ -28,6 +28,7 @@ #:use-module (oop goops) #:use-module (term ansi-color) #:use-module (xapian xapian) + #:use-module (tissue git) #:use-module (tissue utils) #:export (slot-set object->scm @@ -163,7 +164,7 @@ and further text, increase-termpos! must be called before indexing." (define-method (document-text (document <file-document>)) "Return the full text of DOCUMENT." - (call-with-input-file (file-document-path document) + (call-with-file-in-git (current-git-repository) (file-document-path document) get-string-all)) (define-method (document-term-generator (document <file-document>)) @@ -255,7 +256,7 @@ a list of search results." (define (read-gemtext-document file) "Reade gemtext document from FILE. Return a <file-document> object." (make <file-document> - #:title (or (call-with-input-file file + #:title (or (call-with-file-in-git (current-git-repository) file (lambda (port) (port-transduce (tfilter-map (lambda (line) ;; The first level one diff --git a/tissue/issue.scm b/tissue/issue.scm index f6e51ff..02982e1 100644 --- a/tissue/issue.scm +++ b/tissue/issue.scm @@ -312,76 +312,72 @@ in (tissue tissue). If no alias is found, NAME is returned as such." (() name))) (else name))) -(define (file-details file) - "Return a hashtable of details extracted from gemini FILE." +(define (file-details port) + "Return a hashtable of details extracted from input PORT reading a +gemtext file." (let ((result (make-eq-hashtable))) - ;; Files may be renamed or deleted, but not committed. Therefore, - ;; only read the file if it exists. - (when (file-exists? file) - (call-with-input-file file - (lambda (port) - (port-transduce (tmap (lambda (line) - (cond - ;; Checkbox lists are tasks. If the - ;; checkbox has any character other - ;; than space in it, the task is - ;; completed. - ((string-match "^\\* \\[(.)\\]" line) - => (lambda (m) - (hashtable-update! result 'tasks 1+ 0) - (unless (string=? (match:substring m 1) " ") - (hashtable-update! result 'completed-tasks 1+ 0)))) - ((let ((alist (list-line->alist line))) - (and alist - ;; Every value string is 2 - ;; words or less. - (every (match-lambda - ((_ . values) - (every (cut <=n-words? <> 2) - values))) - alist) - alist)) - => (lambda (alist) - ;; Insert values based on - ;; their keys. - (for-each (match-lambda - (((or 'assign 'assigned) . values) - (hashtable-append! result 'assigned - (map (cut resolve-alias <> (%aliases)) - values))) - (((or 'keywords 'severity 'status 'priority 'tags 'type) . values) - (hashtable-append! result 'keywords values)) - (_ #t)) - alist))) - ;; A more fuzzy heuristic to find keywords - ((and (string-prefix? "* " line) - ;; Is every comma-separated - ;; element two words utmost? - (every (cut <=n-words? <> 2) - (comma-split (remove-prefix "* " line))) - ;; Does any comma-separated - ;; element contain a potential - ;; keyword? - (any (lambda (element) - (any (lambda (keyword) - (string-contains element keyword)) - (list "request" "bug" "critical" - "enhancement" "progress" - "testing" "later" "documentation" - "help" "closed"))) - (comma-split (remove-prefix "* " line)))) - (hashtable-append! result 'keywords - (comma-split - (remove-prefix "* " line)))) - ;; The first level one heading is the - ;; title. - ((string-prefix? "# " line) - (unless (hashtable-contains? result 'title) - (hashtable-set! result 'title - (remove-prefix "# " line))))))) - (const #t) - get-line-dos-or-unix - port)))) + (port-transduce (tmap (lambda (line) + (cond + ;; Checkbox lists are tasks. If the + ;; checkbox has any character other + ;; than space in it, the task is + ;; completed. + ((string-match "^\\* \\[(.)\\]" line) + => (lambda (m) + (hashtable-update! result 'tasks 1+ 0) + (unless (string=? (match:substring m 1) " ") + (hashtable-update! result 'completed-tasks 1+ 0)))) + ((let ((alist (list-line->alist line))) + (and alist + ;; Every value string is 2 + ;; words or less. + (every (match-lambda + ((_ . values) + (every (cut <=n-words? <> 2) + values))) + alist) + alist)) + => (lambda (alist) + ;; Insert values based on + ;; their keys. + (for-each (match-lambda + (((or 'assign 'assigned) . values) + (hashtable-append! result 'assigned + (map (cut resolve-alias <> (%aliases)) + values))) + (((or 'keywords 'severity 'status 'priority 'tags 'type) . values) + (hashtable-append! result 'keywords values)) + (_ #t)) + alist))) + ;; A more fuzzy heuristic to find keywords + ((and (string-prefix? "* " line) + ;; Is every comma-separated + ;; element two words utmost? + (every (cut <=n-words? <> 2) + (comma-split (remove-prefix "* " line))) + ;; Does any comma-separated + ;; element contain a potential + ;; keyword? + (any (lambda (element) + (any (lambda (keyword) + (string-contains element keyword)) + (list "request" "bug" "critical" + "enhancement" "progress" + "testing" "later" "documentation" + "help" "closed"))) + (comma-split (remove-prefix "* " line)))) + (hashtable-append! result 'keywords + (comma-split + (remove-prefix "* " line)))) + ;; The first level one heading is the + ;; title. + ((string-prefix? "# " line) + (unless (hashtable-contains? result 'title) + (hashtable-set! result 'title + (remove-prefix "# " line))))))) + (const #t) + get-line-dos-or-unix + port) result)) (define file-modification-table-for-current-repository @@ -390,7 +386,8 @@ in (tissue tissue). If no alias is found, NAME is returned as such." (define (read-gemtext-issue file) "Read issue from gemtext FILE. Return an <issue> object." - (let* ((file-details (file-details file)) + (let* ((file-details (call-with-file-in-git (current-git-repository) file + file-details)) ;; Downcase keywords to make them ;; case-insensitive. (all-keywords (map string-downcase diff --git a/tissue/web/static.scm b/tissue/web/static.scm index 71ef50b..d9a2fb1 100644 --- a/tissue/web/static.scm +++ b/tissue/web/static.scm @@ -30,6 +30,7 @@ #:use-module (skribilo reader) #:use-module (web uri) #:use-module (tissue conditions) + #:use-module (tissue git) #:use-module (tissue issue) #:use-module (tissue utils) #:export (%project-name @@ -72,12 +73,8 @@ NEW-EXTENSION." passed two arguments---the input port to read from and the output port to write to." (lambda (out) - ;; Files may be renamed or deleted, but not committed. Therefore, - ;; raise an exception if the file does not exist. - (if (file-exists? file) - (call-with-input-file file - (cut proc <> out)) - (raise (issue-file-not-found-error file))))) + (call-with-file-in-git (current-git-repository) file + (cut proc <> out)))) (define (copier file) "Return a writer function that copies FILE." |