From d00fea566004e67161ee45246b239fff5d416b0e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 21 Dec 2021 16:17:28 +0100 Subject: Cleanup modules. Primarly this moves all vcompenent input and output code to clearly labeled modules, instead of being spread out. At the same time it also removes a handfull of unused procedures. --- module/vcomponent/util/search.scm | 175 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 175 insertions(+) create mode 100644 module/vcomponent/util/search.scm (limited to 'module/vcomponent/util/search.scm') diff --git a/module/vcomponent/util/search.scm b/module/vcomponent/util/search.scm new file mode 100644 index 00000000..fb395022 --- /dev/null +++ b/module/vcomponent/util/search.scm @@ -0,0 +1,175 @@ +;;; Commentary: + +;; Procedures for searching in a (possibly) infinite stream. Everything is general, +;; with the exception of @var{build-query-proc}, which is tailored for searches on +;; sets on vcomponents. + +;; > TODO since most of this module is generic, break it out and only have the +;; > vcomponent-specific parts here. + +;; A search isn't guaranteed to include all available objects, since each object +;; only has a limited time to get found. This is mostly a problem if the matches +;; are /really/ far from one another. +;; NOTE a system of continuations to allow a search to be resumed with a higher +;; timeout would be cool to have. + +;; Currently all searches is assumed to go through prepare-query and the paginator +;; interface. It shouldn't however be a problem to work with the flat result-set +;; returned by @var{execute-query} directly. + +;; @var{} isn't strictly necessary even for paginated queries, since the +;; evaluation time and pagination is baked into the stream. It is however useful +;; for keeping track of the number of available pages, and if we have found the +;; "final" element. + +;;; Code: + +(define-module (vcomponent util search) + :use-module (calp util) + :use-module (srfi srfi-1) + :use-module (srfi srfi-9) + :use-module (srfi srfi-41) + :use-module (srfi srfi-41 util) + :use-module ((ice-9 sandbox) + :select (make-sandbox-module + all-pure-bindings))) + + +;; 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) + (case char + ((#\() (1+ count)) + ((#\)) (1- count)) + (else count))) + 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)) + +;; TODO place this in a proper module +(define (bindings-for module-name) + ;; Wrapping list so we can later export sub-modules. + (list (cons module-name + (module-map (lambda (a . _) a) + (resolve-interface module-name))))) + +;; 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? + (eval `(lambda (event) ,@expressions) + (make-sandbox-module + `( + ((vcomponent base) prop param children type parent) + ((ice-9 regex) string-match) + ,@(bindings-for '(datetime)) + ,@all-pure-bindings) + ))) + + +;; Returns a new stream which is the result of filtering the input set with the +;; query procedure. +;; (a → bool), (stream a) → (stream a) +(define-public (execute-query query-proc event-set) + (stream-timeslice-limit + (stream-filter query-proc event-set) + ;; .5s, tested on my laptop. .1s sometimes doesn't get to events on + ;; 2020-08-10, where the first event is on 1974-12-02. + 0.5)) + +;; Creates a prepared query wrappend in a paginator. +;; (event → bool), (stream event) → +(define*-public (prepare-query query-proc event-set optional: (page-size 10)) + (make-paginator (stream-paginate (execute-query query-proc event-set) + page-size))) + +(define-record-type + (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!)) + +(define (set-true-max-page! paginator) + (%set-true-max-page! paginator #t)) + +(define (unset-true-max-page! paginator) + (%set-true-max-page! paginator #f)) + +(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 +;; , 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. +;; , int → (list event) throws ('max-page ) +(define-public (get-page paginator page) + (catch 'wrong-type-arg + (lambda () (let ((q (get-query paginator))) + (if (stream-null? q) + (begin + (set-true-max-page! paginator) + '()) + (let ((result (stream->list + (stream-ref (get-query paginator) page)))) + ;; This check isn't strictly necessary, but without it + ;; we always needs to force the next page. And since this + ;; page is "incomplete" we already know that this is the + ;; final page. + (when (> 10 (length result)) + (set-true-max-page! paginator)) + + (set-max-page! paginator (max page (get-max-page paginator))) + result)))) + (lambda (err proc fmt args data) + ;; NOTE This is mostly a hack to see that we + ;; actually check for the correct error. + (unless (string=? fmt "beyond end of stream") + (scm-error err proc fmt args data)) + + (set-max-page! paginator (get-max-page paginator)) + (set-true-max-page! paginator) + (throw 'max-page (get-max-page paginator)) + ))) + + -- cgit v1.2.3