;;; 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 (rnrs arithmetic bitwise)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-26)
  #:use-module (xapian wrap)
  #:export (xapian-open
            xapian-close
            call-with-database
            database-document-count
            xapian-open-writable
            xapian-close-writable
            call-with-writable-database
            add-document!
            replace-document!
            make-document
            document-data
            document-slot-ref
            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
            mset-snippet))

(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 database-document-count Database-get-doccount)

(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 '()) (values '()))
  (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)
    (for-each (match-lambda
                ((slot . value)
                 (Document-add-value doc slot value)))
              values)
    doc))

(define document-data Document-get-data)
(define document-slot-ref Document-get-value)

(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 #:key (offset 0) maximum-items)
  "Run a query using the settings in the ENQUIRE object and return an
mset object.

OFFSET specifies the number of items to ignore at the beginning of the
result set.

MAXIMUM-ITEMS specifies the maximum number of items to return. To
return all matches, pass the result of calling database-document-count
on the database object."
  (Enquire-get-mset enquire offset maximum-items))

(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))))))

(define (get-flag flag-thunk value)
  (if value (flag-thunk) 0))

;; TODO: Support cjk-words?
(define* (mset-snippet mset text
                       #:key (length 500) (stemmer (make-stem "none"))
                       (highlight-start "<b>") (highlight-end "</b>") (omit "...")
                       (background-model? #t) (exhaustive? #t)
                       (empty-without-match? #t)
                       (cjk-ngram? #t))
  (MSet-snippet mset text length stemmer
                (bitwise-ior (get-flag MSet-SNIPPET-BACKGROUND-MODEL background-model?)
                             (get-flag MSet-SNIPPET-EXHAUSTIVE exhaustive?)
                             (get-flag MSet-SNIPPET-EMPTY-WITHOUT-MATCH empty-without-match?)
                             (get-flag MSet-SNIPPET-CJK-NGRAM cjk-ngram?))
                highlight-start highlight-end omit))