summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rwxr-xr-xbin/tissue111
-rw-r--r--tissue/conditions.scm9
-rw-r--r--tissue/document.scm189
-rw-r--r--tissue/issue.scm200
4 files changed, 244 insertions, 265 deletions
diff --git a/bin/tissue b/bin/tissue
index 3ae62eb..492bda7 100755
--- a/bin/tissue
+++ b/bin/tissue
@@ -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)))