First commit.

1 files changed, 124 insertions, 0 deletions

diff --git a/xapian/xapian.scm b/xapian/xapian.scm
new file mode 100644
index 0000000..8801838
--- /dev/null
+++ b/xapian/xapian.scm
@@ -0,0 +1,124 @@
+;;; guile-xapian --- Guile bindings for Xapian
+;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
+;;;
+;;; This file is part of guile-xapian.
+;;;
+;;; guile-xapian is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation, either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; guile-xapian is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with guile-xapian.  If not, see
+;;; <https://www.gnu.org/licenses/>.
+
+(define-module (xapian xapian)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-26)
+  #:use-module (xapian wrap)
+  #:export (xapian-open
+            xapian-close
+            call-with-database
+            xapian-open-writable
+            xapian-close-writable
+            call-with-writable-database
+            add-document!
+            replace-document!
+            make-document
+            document-data
+            make-stem
+            make-term-generator
+            index-text!
+            increase-termpos!
+            parse-query
+            enquire
+            enquire-mset
+            mset-item-docid
+            mset-item-document
+            mset-item-rank
+            mset-item-weight
+            mset-fold))
+
+(define xapian-open new-Database)
+(define xapian-close delete-Database)
+
+(define (call-with-database dbpath proc)
+  (let ((db (xapian-open dbpath)))
+    (dynamic-wind noop (cut proc db) (cut xapian-close db))))
+
+(define xapian-open-writable new-WritableDatabase)
+(define xapian-close-writable delete-WritableDatabase)
+
+(define (call-with-writable-database dbpath proc)
+  (let ((db (xapian-open-writable dbpath)))
+    (dynamic-wind noop (cut proc db) (cut xapian-close-writable db))))
+
+(define add-document! WritableDatabase-add-document)
+(define replace-document! WritableDatabase-replace-document)
+
+(define* (make-document #:key data (terms '()))
+  (let ((doc (new-Document)))
+    (when data
+      (Document-set-data doc data))
+    (for-each (match-lambda
+                ((term . wdf-increment)
+                 (Document-add-term doc term wdf-increment)))
+              terms)
+    doc))
+
+(define document-data Document-get-data)
+
+(define make-stem new-Stem)
+
+(define* (make-term-generator #:key stem document)
+  (let ((term-generator (new-TermGenerator)))
+    (TermGenerator-set-stemmer term-generator stem)
+    (TermGenerator-set-document term-generator document)
+    term-generator))
+
+(define* (index-text! term-generator text #:key (wdf-increment 1) prefix)
+  (apply TermGenerator-index-text term-generator text wdf-increment
+         (if prefix (list prefix) '())))
+
+(define increase-termpos! TermGenerator-increase-termpos)
+
+(define* (parse-query querystring #:key stemmer stemming-strategy (prefixes '()))
+  (let ((queryparser (new-QueryParser)))
+    (QueryParser-set-stemmer queryparser stemmer)
+    (when stemming-strategy
+      (QueryParser-set-stemming-strategy queryparser stemming-strategy))
+    (for-each (match-lambda
+                ((field . prefix)
+                 (QueryParser-add-prefix queryparser field prefix)))
+              prefixes)
+    (let ((query (QueryParser-parse-query queryparser querystring)))
+      (delete-QueryParser queryparser)
+      query)))
+
+(define* (enquire db query #:key weighting-scheme)
+  (let ((enquire (new-Enquire db)))
+    (Enquire-set-query enquire query)
+    (when weighting-scheme
+      (Enquire-set-weighting-scheme enquire weighting-scheme))
+    enquire))
+
+(define enquire-mset Enquire-get-mset)
+
+(define mset-item-docid MSetIterator-get-docid)
+(define mset-item-document MSetIterator-get-document)
+(define mset-item-rank MSetIterator-get-rank)
+(define mset-item-weight MSetIterator-get-weight)
+
+(define (mset-fold proc init mset)
+  (let loop ((head (MSet-begin mset))
+             (result init))
+    (cond
+     ((MSetIterator-equals head (MSet-end mset)) result)
+     (else (let ((result (proc head result)))
+             (MSetIterator-next head)
+             (loop head result))))))