From e0348f347c1c95c0cb527cd2389a107cd7305ef6 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Mon, 27 Jun 2022 18:09:16 +0530 Subject: Migrate to GOOPS. * tissue/document.scm: Do not import (srfi srfi-9). Import (srfi srfi-19), (ice-9 match) and (oop goops). (): Delete type. (, ): New classes. (date->alist, alist->date, object->scm, scm->object): New functions. (document->alist, alist->document, print-document): Delete functions. (document-term-generator, document-type, document-id-term, document-text, print): New generic methods. (read-gemtext-document): Return object. (index-document): Delete function. * tissue/issue.scm: Do not import (srfi srfi-9) and (srfi srfi-19). Import (oop goops) and (tissue document). (date->iso-8601, iso-8601->date): Move to tissue/document.scm. (, ): Re-implement as class. (issue->alist, post->alist, alist->issue, alist->post, index-issue): Delete functions. (print-issue): Rename to print, a generic method. (print): Use document-title and file-document-path instead of issue-title and issue-file respectively. Accept mset argument. (print-issue-to-gemtext): Use document-title instead of issue-title. (read-gemtext-issue): Return a object. (document-term-generator): New generic methods. * bin/tissue: Import (tissue document) without a prefix. (print-document, alist->document, document->text, index-document): Delete functions. (tissue-search): Use the print generic function. (main): Use the document-type, document-id-term, document-term-generator generic functions and replace-document! instead of index-document. * tissue/conditions.scm (&unknown-document-type-violation): Delete condition. --- bin/tissue | 111 +++++++++++++++++++------------------------------------------ 1 file changed, 35 insertions(+), 76 deletions(-) (limited to 'bin') 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 or 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 or 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 or 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 or 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. -- cgit v1.2.3