diff options
Diffstat (limited to 'module/vcomponent/search.scm')
| -rw-r--r-- | module/vcomponent/search.scm | 109 |
1 files changed, 82 insertions, 27 deletions
diff --git a/module/vcomponent/search.scm b/module/vcomponent/search.scm index 5cb91e51..571279e7 100644 --- a/module/vcomponent/search.scm +++ b/module/vcomponent/search.scm @@ -1,11 +1,15 @@ (define-module (vcomponent search) :use-module (util) :use-module (ice-9 sandbox) + :use-module (srfi srfi-1) + :use-module (srfi srfi-9) :use-module (srfi srfi-41) :use-module (srfi srfi-41 util) ) +;; Takes a string and appends closing parenthese until all parenthese are +;; closed. (define (close-parenthese str) (define missing-parenthesis-count (string-fold (lambda (char count) @@ -16,9 +20,16 @@ 0 str)) (string-append str (make-string missing-parenthesis-count #\)))) +;; Prepares a string to be sent to build-query-proc +;; sexp-like string -> sexp (define-public (prepare-string str) (call-with-input-string (close-parenthese str) read)) +;; Evaluates the given expression in a sandbox. +;; NOTE Should maybe be merged inte prepare-query. The argument against is that +;; eval-in-sandbox is possibly slow, and that would prevent easy caching by the +;; caller. +;; sexp -> (event → bool) (define-public (build-query-proc . expressions) ;; TODO does this eval help? Or will the body of the procedure ;; be evalutade later? @@ -31,33 +42,77 @@ ,@all-pure-bindings) ))) +;; execute a query procedure created by build-query-proc. +;; (event → bool), int, (optional int) → (list event) throws 'timed-out +(define* (execute-query query page key: (time-limit 1)) + (call-with-time-limit + time-limit + ;; Stream->list needs to be here, since the actual + ;; stream-force needs to happen within the actual + ;; @var{call-with-time-limit}. + (lambda () (stream->list (stream-ref query page))) + (lambda _ (throw 'timed-out)))) + +;; Creates a prepared query wrappend in a paginator. +;; (event → bool), (stream event) → <paginator> (define-public (prepare-query query-proc event-set) - (stream-paginate (stream-filter query-proc event-set)) ) - -;; TODO possibly make this procedure deny any query-procedures not created by -;; build-query-procedure -;; (event → bool), (stream event), (() → Any) → (paginated-stream event) -(define*-public (execute-query query page - key: - ;; time-out-handler - (time-limit 1)) - (catch 'not-an-actual-error ; 'timed-out - (lambda () - (call-with-time-limit - time-limit - ;; Stream->list needs to be here, since the actual - ;; stream-force needs to happen within the actual - ;; @var{call-with-time-limit}. - (lambda () (stream->list (stream-ref query page))) - (lambda _ (throw 'timed-out)))) + (make-paginator (stream-paginate (stream-filter query-proc event-set)))) + +(define-record-type <paginator> + (make-paginator% query max-page true-max-page?) + paginator? + (query get-query) ; (paginated-stream event) + (max-page get-max-page set-max-page!) ; int + (true-max-page? true-max-page? set-true-max-page!)) + +(export paginator? get-query get-max-page true-max-page?) + +(define (make-paginator query) + (make-paginator% query 0 #f)) + +;; a fancy version of 1+ which caps at max page +;; <paginator>, int → int +(define*-public (next-page paginator optional: (page (get-max-page paginator))) + (if (true-max-page? paginator) + (min (1+ page) (get-max-page paginator)) + (1+ page))) + +(define-public (paginator->list paginator proc tail-proc) + (if (true-max-page? paginator) + (map proc (iota (1+ (get-max-page paginator)))) + (append (map proc (iota (1+ (get-max-page paginator)))) + (list (tail-proc (next-page paginator)))))) + + +(define*-public (paginator->sub-list paginator current-page proc + key: head-proc tail-proc + (ahead 5) (behind 5) + ) + + (let ((start (max 0 (- current-page behind))) + (end (min (+ current-page ahead) + (get-max-page paginator)))) + + (display (head-proc start)) + (for-each proc (iota (1+ (- end start)) start)) + (display (tail-proc end))) + + ) + +;; returns the contents of the requested page, or throws 'max-page with the +;; highest known available page. +;; <paginator>, int → (list event) throws ('max-page <int>) +(define-public (get-page paginator page) + (catch 'timed-out + (lambda () (let ((result (execute-query (get-query paginator) page))) + (set-max-page! paginator (max page (get-max-page paginator))) + (when (> 10 (length result)) + (set-true-max-page! paginator #t)) + result)) (lambda (err . args) - (display (cons err args) (current-error-port)) - (newline (current-error-port)) - (case err - ((timed-out) (aif time-out-handler (it) - (apply throw err 'args)))) - 'timed-out ; when search took to long - 'unbound-variable ; when search term has unbound variables - 'wrong-type-arg ;; stream-ref - '()))) + (set-max-page! paginator (get-max-page paginator)) + (set-true-max-page! paginator #t) + (throw 'max-page (get-max-page paginator))))) + + |