diff options
| -rwxr-xr-x | bin/tissue | 111 | ||||
| -rw-r--r-- | tissue/conditions.scm | 9 | ||||
| -rw-r--r-- | tissue/document.scm | 189 | ||||
| -rw-r--r-- | tissue/issue.scm | 200 |
4 files changed, 244 insertions, 265 deletions
@@ -37,7 +37,7 @@ exec guile --no-auto-compile -s "$0" "$@" (xapian wrap) (xapian xapian) (tissue conditions) - (prefix (tissue document) doc:) + (tissue document) (tissue git) (tissue issue) (tissue tissue) @@ -72,32 +72,6 @@ to run tissue." (match (command-line) ((program _ ...) program))) -(define (print-document document) - "Print DOCUMENT, an <issue> or <document> object." - ((cond - ((issue? document) print-issue) - ((doc:document? document) doc:print-document) - (else (raise (unknown-document-type-violation document)))) - document)) - -(define (alist->document alist) - "Convert ALIST to an <issue> or <document> object." - ((case (assq-ref alist 'type) - ((issue) alist->issue) - ((document) doc:alist->document) - (else (raise (unknown-document-type-violation alist)))) - alist)) - -(define (document->text document) - "Return the text of DOCUMENT, an <issue> or <document> object." - (call-with-input-file - ((cond - ((issue? document) issue-file) - ((doc:document? document) doc:document-file) - (else (raise (unknown-document-type-violation document)))) - document) - get-string-all)) - (define tissue-search (match-lambda* (("--help") @@ -108,47 +82,36 @@ Search issues using SEARCH-QUERY. (args (call-with-database %xapian-index (lambda (db) - (let* ((stemmer (make-stem "en")) - (query (parse-query - ;; When query does not mention type or state, - ;; assume is:open. Assuming is:open is - ;; implicitly assuming type:issue since only - ;; issues can have is:open. - (if (every string-null? args) - "is:open" - (string-join (if (any (lambda (query-string) - (or (string-contains-ci query-string "type:") - (string-contains-ci query-string "is:"))) - args) - args - (cons "is:open" args)) - " AND ")) - #:stemmer stemmer - #:prefixes '(("type" . "XT") - ("title" . "S") - ("creator" . "A") - ("last-updater" . "XA") - ("updater" . "XA") - ("assigned" . "XI") - ("keyword" . "K") - ("tag" . "K") - ("is" . "XS"))))) + (let ((query (parse-query + ;; When query does not mention type or state, + ;; assume is:open. Assuming is:open is + ;; implicitly assuming type:issue since only + ;; issues can have is:open. + (if (every string-null? args) + "is:open" + (string-join (if (any (lambda (query-string) + (or (string-contains-ci query-string "type:") + (string-contains-ci query-string "is:"))) + args) + args + (cons "is:open" args)) + " AND ")) + #:stemmer (make-stem "en") + #:prefixes '(("type" . "XT") + ("title" . "S") + ("creator" . "A") + ("last-updater" . "XA") + ("updater" . "XA") + ("assigned" . "XI") + ("keyword" . "K") + ("tag" . "K") + ("is" . "XS"))))) (format #t "total ~a~%" (mset-fold (lambda (item count) - (let ((document (call-with-input-string (document-data (mset-item-document item)) - (compose alist->document read)))) - (print-document document) - (let ((snippet (mset-snippet (MSetIterator-mset-get item) - (document->text document) - #:length 200 - #:highlight-start (color 'BOLD 'ON-RED) - #:highlight-end (color 'RESET) - #:stemmer stemmer))) - (unless (string-null? snippet) - (display snippet) - (newline) - (newline))) - (1+ count))) + (print (call-with-input-string (document-data (mset-item-document item)) + (compose scm->object read)) + (MSetIterator-mset-get item)) + (1+ count)) 0 (enquire-mset (enquire db query) #:maximum-items (database-document-count db)))))))))) @@ -280,15 +243,6 @@ top-level of the git repository." (negate (cut member <> (list "." ".."))))) (rmdir %xapian-index))) -(define (index-document db document) - "Index DOCUMENT, an <issue> or <document> object, in writable xapian -DB." - ((cond - ((issue? document) index-issue) - ((doc:document? document) doc:index-document) - (else (raise (unknown-document-type-violation document)))) - db document)) - (define main (match-lambda* ((_ (or "-h" "--help")) @@ -322,7 +276,12 @@ DB." (call-with-writable-database %xapian-index (lambda (db) (for-each (lambda (indexed-document) - (index-document db ((indexed-document-reader indexed-document)))) + (let* ((document ((indexed-document-reader indexed-document))) + (term-generator (document-term-generator document))) + (index-text! term-generator (document-type document) #:prefix "XT") + (replace-document! db + (document-id-term document) + (TermGenerator-get-document term-generator)))) (tissue-configuration-indexed-documents (load-config))) (WritableDatabase-set-metadata db "commit" current-head)))))) ;; Handle sub-command. diff --git a/tissue/conditions.scm b/tissue/conditions.scm index e09e8b8..b2ae543 100644 --- a/tissue/conditions.scm +++ b/tissue/conditions.scm @@ -20,15 +20,8 @@ #:use-module (rnrs conditions) #:export (issue-file-not-found-error issue-file-not-found-error? - issue-file-not-found-error-issue-file - unknown-document-type-violation - unknown-document-type-violation? - unknown-document-type-violation-document)) + issue-file-not-found-error-issue-file)) (define-condition-type &issue-file-not-found-error &error issue-file-not-found-error issue-file-not-found-error? (issue-file issue-file-not-found-error-issue-file)) - -(define-condition-type &unknown-document-type-violation &violation - unknown-document-type-violation unknown-document-type-violation? - (document unknown-document-type-violation-document)) diff --git a/tissue/document.scm b/tissue/document.scm index 202ea35..c70b18e 100644 --- a/tissue/document.scm +++ b/tissue/document.scm @@ -19,52 +19,154 @@ (define-module (tissue document) #:use-module (rnrs hashtables) #:use-module (rnrs io ports) - #:use-module (srfi srfi-9) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-171) + #:use-module (ice-9 match) + #:use-module (oop goops) #:use-module (term ansi-color) #:use-module (xapian xapian) #:use-module (tissue utils) - #:export (document - document? - document-file + #:export (object->scm + scm->object + <document> document-title - document->alist - alist->document - print-document - read-gemtext-document - index-document)) - -(define-record-type <document> - (document file title) - document? - (file document-file) - (title document-title)) - -(define (document->alist document) - "Convert DOCUMENT, a <document> object, to an association list that -can be serialized." - `((type . document) - (file . ,(document-file document)) - (title . ,(document-title document)))) - -(define (alist->document alist) - "Convert ALIST to a <document> object." - (document (assq-ref alist 'file) - (assq-ref alist 'title))) - -(define (print-document document) - "Print DOCUMENT, a <document> object, in search results." + document-type + document-id-term + document-text + document-term-generator + print + <file-document> + file-document-path + read-gemtext-document)) + +(define (date->iso-8601 date) + "Convert DATE, an SRFI-19 date object, to an ISO-8601 date string." + (date->string date "~4")) + +(define (iso-8601->date str) + "Convert STR, an ISO-8601 date string, to an SRFI-19 date object." + (string->date str "~Y-~m-~dT~H:~M:~S~z")) + +(define (date->alist date) + "Convert DATE, an SRFI-19 date object, to an association list." + `((type . <date>) + (iso-8601 . ,(date->iso-8601 date)))) + +(define (alist->date alist) + "Convert an association list to an SRFI-19 date object." + (iso-8601->date (assq-ref alist 'iso-8601))) + +(define (object->scm object) + "Convert GOOPS OBJECT to a serializable object." + (cond + ((or (string? object) + (number? object) + (boolean? object)) + object) + ((date? object) + (date->alist object)) + ((list? object) + (list->vector (map object->scm object))) + (else + (cons (cons 'type (class-name (class-of object))) + (map (lambda (slot) + (let* ((slot-name (slot-definition-name slot)) + (value (if (slot-bound? object slot-name) + (slot-ref object slot-name) + (goops-error "Unbound slot ~s in ~s" slot-name object)))) + (cons slot-name (object->scm value)))) + (class-slots (class-of object))))))) + +(define (scm->object scm) + "Convert serializable object SCM to a GOOPS object." + (cond + ((or (string? scm) + (number? scm) + (boolean? scm)) + scm) + ((vector? scm) + (map scm->object (vector->list scm))) + ;; Association list encoding date + ((eq? (assq-ref scm 'type) + '<date>) + (alist->date scm)) + ;; Association list encoding arbitrary object + (else + (let* ((class (module-ref (current-module) + (assq-ref scm 'type))) + (object (make class))) + (for-each (match-lambda + ((slot-name . value) + (unless (eq? slot-name 'type) + (slot-set! object slot-name (scm->object value))))) + scm) + object)))) + +(define-class <document> () + (title #:accessor document-title #:init-keyword #:title)) + +(define-method (document-type (document <document>)) + "document") + +(define-method (document-term-generator (document <document>)) + "Return a term generator for DOCUMENT. The returned term generator has +indexed the type and text of the document. If further free text is to +be indexed, to prevent phrase searches from spanning between this text +and further text, increase-termpos! must be called before indexing." + (let ((term-generator + (make-term-generator + #:stem (make-stem "en") + #:document (make-document + #:data (call-with-output-string + (cut write (object->scm document) <>)) + #:terms `((,(document-id-term document) . 0)))))) + (index-text! term-generator (document-title document) #:prefix "S") + (index-text! term-generator (document-text document)) + term-generator)) + +(define-class <file-document> (<document>) + (path #:accessor file-document-path #:init-keyword #:path)) + +(define-method (document-id-term (document <file-document>)) + "Return the ID term for DOCUMENT." + (string-append "Q" (file-document-path document))) + +(define-method (document-text (document <file-document>)) + "Return the full text of DOCUMENT." + (call-with-input-file (file-document-path document) + get-string-all)) + +(define-method (document-term-generator (document <file-document>)) + "Return a term generator indexing DOCUMENT." + (let ((term-generator (next-method))) + (increase-termpos! term-generator) + (index-text! term-generator (file-document-path document)) + term-generator)) + +(define-method (print (document <file-document>) mset) + "Print DOCUMENT in command-line search results. MSET is the xapian +MSet object representing a list of search results." (display (colorize-string (document-title document) 'MAGENTA 'UNDERLINE)) (newline) - (display (colorize-string (document-file document) 'YELLOW)) + (display (colorize-string (file-document-path document) 'YELLOW)) + (newline) (newline) - (newline)) + (let ((snippet (mset-snippet mset + (document-text document) + #:length 200 + #:highlight-start (color 'BOLD 'ON-RED) + #:highlight-end (color 'RESET) + #:stemmer (make-stem "en")))) + (unless (string-null? snippet) + (display snippet) + (newline) + (newline)))) (define (read-gemtext-document file) - "Reade gemtext document from FILE. Return a <document> object." - (document file - (or (call-with-input-file file + "Reade gemtext document from FILE. Return a <file-document> object." + (make <file-document> + #:title (or (call-with-input-file file (lambda (port) (port-transduce (tfilter-map (lambda (line) ;; The first level one @@ -75,18 +177,5 @@ can be serialized." get-line-dos-or-unix port))) ;; Fallback to filename if document has no title. - file))) - -(define (index-document db document) - "Index DOCUMENT, a <document> object, in writable xapian DB." - (let* ((idterm (string-append "Q" (document-file document))) - (body (call-with-input-file (document-file document) - get-string-all)) - (doc (make-document #:data (call-with-output-string - (cut write (document->alist document) <>)) - #:terms `((,idterm . 0)))) - (term-generator (make-term-generator #:stem (make-stem "en") - #:document doc))) - (index-text! term-generator "document" #:prefix "XT") - (index-text! term-generator body) - (replace-document! db idterm doc))) + file) + #:path file)) diff --git a/tissue/issue.scm b/tissue/issue.scm index 4dd1854..076e727 100644 --- a/tissue/issue.scm +++ b/tissue/issue.scm @@ -21,22 +21,19 @@ #:use-module (rnrs hashtables) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-171) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (oop goops) #:use-module (term ansi-color) #:use-module (git) #:use-module (xapian xapian) + #:use-module (tissue document) #:use-module (tissue git) #:use-module (tissue utils) #:export (%aliases - issue - issue? - issue-file - issue-title + <issue> issue-creator issue-created-date issue-last-updater @@ -47,8 +44,7 @@ issue-tasks issue-completed-tasks issue-posts - post - post? + <post> post-author post-date issue->alist @@ -64,86 +60,44 @@ (define %aliases (make-parameter #f)) -(define-record-type <issue> - (issue file title creator created-date last-updater last-updated-date - assigned keywords open tasks completed-tasks posts) - issue? - (file issue-file) - (title issue-title) - (creator issue-creator) - (created-date issue-created-date) - (last-updater issue-last-updater) - (last-updated-date issue-last-updated-date) - (assigned issue-assigned) - (keywords issue-keywords) - (open issue-open?) - (tasks issue-tasks) - (completed-tasks issue-completed-tasks) +(define-class <issue> (<file-document>) + (creator #:accessor issue-creator #:init-keyword #:creator) + (created-date #:accessor issue-created-date #:init-keyword #:created-date) + (last-updater #:accessor issue-last-updater #:init-keyword #:last-updater) + (last-updated-date #:accessor issue-last-updated-date #:init-keyword #:last-updated-date) + (assigned #:accessor issue-assigned #:init-keyword #:assigned) + (keywords #:accessor issue-keywords #:init-keyword #:keywords) + (open? #:accessor issue-open? #:init-keyword #:open?) + (tasks #:accessor issue-tasks #:init-keyword #:tasks) + (completed-tasks #:accessor issue-completed-tasks #:init-keyword #:completed-tasks) ;; List of <post> objects, oldest first. - (posts issue-posts)) + (posts #:accessor issue-posts #:init-keyword #:posts)) -(define-record-type <post> - (post author date) - post? - (author post-author) - (date post-date)) +(define-class <post> () + (author #:accessor post-author #:init-keyword #:author) + (date #:accessor post-date #:init-keyword #:date)) -(define (date->iso-8601 date) - "Convert DATE, an SRFI-19 date object, to an ISO-8601 date string." - (date->string date "~4")) +(define-method (document-type (issue <issue>)) + "issue") -(define (iso-8601->date str) - "Convert STR, an ISO-8601 date string, to an SRFI-19 date object." - (string->date str "~Y-~m-~dT~H:~M:~S~z")) - -(define (issue->alist issue) - "Convert ISSUE, a <issue> object, to an association list that can be -serialized." - `((type . issue) - (file . ,(issue-file issue)) - (title . ,(issue-title issue)) - (creator . ,(issue-creator issue)) - (created-date . ,(date->iso-8601 (issue-created-date issue))) - (last-updater . ,(issue-last-updater issue)) - (last-updated-date . ,(date->iso-8601 (issue-last-updated-date issue))) - (assigned . ,(issue-assigned issue)) - (keywords . ,(issue-keywords issue)) - (open . ,(issue-open? issue)) - (tasks . ,(issue-tasks issue)) - (completed-tasks . , (issue-completed-tasks issue)) - (posts . ,(map post->alist (issue-posts issue))))) - -(define (post->alist post) - "Convert POST, a <post> object, to an association list that can be -serialized." - `((author . ,(post-author post)) - (date . ,(date->iso-8601 (post-date post))))) - -(define (alist->issue alist) - "Convert ALIST to an <issue> object." - (issue (assq-ref alist 'file) - (assq-ref alist 'title) - (assq-ref alist 'creator) - (iso-8601->date (assq-ref alist 'created-date)) - (assq-ref alist 'last-updater) - (iso-8601->date (assq-ref alist 'last-updated-date)) - (assq-ref alist 'assigned) - (assq-ref alist 'keywords) - (assq-ref alist 'open) - (assq-ref alist 'tasks) - (assq-ref alist 'completed-tasks) - (map alist->post - (assq-ref alist 'posts)))) - -(define (alist->post alist) - "Convert ALIST to a <post> object." - (post (assq-ref alist 'author) - (iso-8601->date (assq-ref alist 'date)))) +(define-method (document-term-generator (issue <issue>)) + "Return a term generator indexing ISSUE." + (let ((term-generator (next-method))) + (index-person! term-generator (issue-creator issue) "A") + (index-person! term-generator (issue-last-updater issue) "XA") + (for-each (cut index-person! term-generator <> "XI") + (issue-assigned issue)) + (for-each (cut index-text! term-generator <> #:prefix "K") + (issue-keywords issue)) + (index-text! term-generator + (if (issue-open? issue) "open" "closed") + #:prefix "XS") + term-generator)) -(define (print-issue issue) +(define-method (print (issue <issue>) mset) "Print ISSUE, an <issue> object, in search results." (let ((number-of-posts (length (issue-posts issue)))) - (display (colorize-string (issue-title issue) 'MAGENTA 'UNDERLINE)) + (display (colorize-string (document-title issue) 'MAGENTA 'UNDERLINE)) (unless (null? (issue-keywords issue)) (display " ") (display (string-join (map (cut colorize-string <> 'ON-BLUE) @@ -160,7 +114,7 @@ serialized." (number->string number-of-posts) " posts]"))) (newline) - (display (colorize-string (issue-file issue) 'YELLOW)) + (display (colorize-string (file-document-path issue) 'YELLOW)) (newline) (display (string-append "opened " @@ -182,12 +136,21 @@ serialized." (number->string (issue-tasks issue)) " tasks done"))) (newline) - (newline))) + (let ((snippet (mset-snippet mset + (document-text issue) + #:length 200 + #:highlight-start (color 'BOLD 'ON-RED) + #:highlight-end (color 'RESET) + #:stemmer (make-stem "en")))) + (unless (string-null? snippet) + (display snippet) + (newline) + (newline))))) (define (print-issue-to-gemtext issue) "Print ISSUE to gemtext." (let ((number-of-posts (length (issue-posts issue)))) - (format #t "# ~a" (issue-title issue)) + (format #t "# ~a" (document-title issue)) (unless (null? (issue-keywords issue)) (format #t " [~a]" (string-join (issue-keywords issue) @@ -366,26 +329,28 @@ in (tissue tissue). If no alias is found, NAME is returned as such." (resolve-alias (signature-name (commit-author commit)) (%aliases))) commits))) - (issue file - ;; Fallback to filename if title has no alphabetic - ;; characters. - (let ((title (hashtable-ref file-details 'title ""))) - (if (string-any char-set:letter title) title file)) - (first commit-authors) - (commit-date (first commits)) - (last commit-authors) - (commit-date (last commits)) - (hashtable-ref file-details 'assigned '()) - ;; "closed" is a special keyword to indicate - ;; the open/closed status of an issue. - (delete "closed" all-keywords) - (not (member "closed" all-keywords)) - (hashtable-ref file-details 'tasks 0) - (hashtable-ref file-details 'completed-tasks 0) - (map (lambda (commit author) - (post author (commit-date commit))) - commits - commit-authors)))) + (make <issue> + #:path file + ;; Fallback to filename if title has no alphabetic characters. + #:title (let ((title (hashtable-ref file-details 'title ""))) + (if (string-any char-set:letter title) title file)) + #:creator (first commit-authors) + #:created-date (commit-date (first commits)) + #:last-updater (last commit-authors) + #:last-updated-date (commit-date (last commits)) + #:assigned (hashtable-ref file-details 'assigned '()) + ;; "closed" is a special keyword to indicate the open/closed + ;; status of an issue. + #:keywords (delete "closed" all-keywords) + #:open? (not (member "closed" all-keywords)) + #:tasks (hashtable-ref file-details 'tasks 0) + #:completed-tasks (hashtable-ref file-details 'completed-tasks 0) + #:posts (map (lambda (commit author) + (make <post> + #:author author + #:date (commit-date commit))) + commits + commit-authors)))) (define (index-person term-generator name prefix) "Index all aliases of person of canonical NAME using TERM-GENERATOR @@ -393,30 +358,3 @@ with PREFIX." (for-each (cut index-text! term-generator <> #:prefix prefix) (or (assoc name (%aliases)) (list)))) - -(define (index-issue db issue) - "Index ISSUE in writable xapian DB." - (let* ((idterm (string-append "Q" (issue-file issue))) - (body (call-with-input-file (issue-file issue) - get-string-all)) - (doc (make-document #:data (call-with-output-string - (cut write (issue->alist issue) <>)) - #:terms `((,idterm . 0)))) - (term-generator (make-term-generator #:stem (make-stem "en") - #:document doc))) - ;; Index metadata with various prefixes. - (index-text! term-generator "issue" #:prefix "XT") - (index-text! term-generator (issue-title issue) #:prefix "S") - (index-person term-generator (issue-creator issue) "A") - (index-person term-generator (issue-last-updater issue) "XA") - (for-each (cut index-person term-generator <> "XI") - (issue-assigned issue)) - (for-each (cut index-text! term-generator <> #:prefix "K") - (issue-keywords issue)) - (index-text! term-generator - (if (issue-open? issue) "open" "closed") - #:prefix "XS") - ;; Index body without prefixes for free text search. - (index-text! term-generator body) - ;; Add document to database. - (replace-document! db idterm doc))) |