Create search module, update term to use it.

2 files changed, 84 insertions, 47 deletions

diff --git a/module/output/terminal.scm b/module/output/terminal.scm
index 1d88015a..c1d84d2b 100644
--- a/module/output/terminal.scm
+++ b/module/output/terminal.scm
@@ -15,13 +15,13 @@
 
   #:use-module (vcomponent)
   #:use-module (vcomponent datetime)
+  #:use-module (vcomponent search)
 
   #:use-module (text util)
   #:use-module (text flow)
 
   #:use-module (ice-9 format)
   #:use-module (ice-9 readline)
-  #:use-module (ice-9 sandbox)
   #:use-module (ice-9 match)
 
   #:use-module (vulgar termios)
@@ -208,38 +208,24 @@
 (define (search-view search-term event-set)
   (make <search-view> search-term: search-term event-set: event-set))
 
-(define (prepare-string 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 #\))))
 
 (define-method (initialize (this <search-view>) args)
   (set! (current-page this) 0)
   (next-method)
   ;; (display (search-term this)) (newline)
-  (slot-set! this 'search-result
-             (stream-paginate
-              (stream-filter
-               (eval `(lambda (event) ,(set/r! (search-term this)
-                                          (call-with-input-string
-                                              (prepare-string (search-term this))
-                                            read)))
-                     (make-sandbox-module
-                      `(
-                        ((vcomponent base) prop)
-                        ((ice-9 regex) string-match)
-                        #;
-                        ((datetime) ,@(module-map (lambda (a . _) a) ; ;
-                        (resolve-module '(datetime))))
-                        ,@all-pure-bindings)
-                      ))
-               (get-event-set this))))
+  (format (current-error-port) "Entering search view~%")
+  (set! (search-term this)
+    (prepare-string (search-term this)))
+
+  (format (current-error-port) "String preprade")
+  (let ((q (build-query-proc (search-term this))))
+    (format (current-error-port) "Query built~%")
+    (slot-set! this 'search-result
+               (prepare-query
+                q
+                (get-event-set this)))
+    (format (current-error-port) "Query prepared~%")
+    )
   ;; (define current-page 0)
   ;; (define current-entry 0)
   )
@@ -247,25 +233,13 @@
 (define-method (output (this <search-view>))
   (unless (cached-page this)
     (set! (cached-page this)
-      (catch #t
-        (lambda ()
-          (call-with-time-limit
-           1
-           (lambda () (stream->list (stream-ref (search-result this) (current-page this))))
-           (lambda _ (throw 'timed-out))))
-        (lambda (err . args)
-          (display (cons err args) (current-error-port))
-          (newline  (current-error-port))
-          (case err
-            ((timed-out) (set! (max-page this) (cons #t (1- (current-page this)))
-                               (current-page this) (cdr (max-page this)))))
-          'timed-out                     ; when search took to long
-          'unbound-variable              ; when search term has unbound variables
-          'wrong-type-arg                ;; stream-ref
-          '()
-
-          )
-        )))
+      (execute-query
+       (slot-ref this 'search-result)
+       (current-page this)
+       time-out-handler:
+       (lambda () (set! (max-page this) (cons #t (1- (current-page this)))
+                   (current-page this) (cdr (max-page this)))))))
+
 
   (cls)
 
diff --git a/module/vcomponent/search.scm b/module/vcomponent/search.scm
new file mode 100644
index 00000000..e92e166f
--- /dev/null
+++ b/module/vcomponent/search.scm
@@ -0,0 +1,63 @@
+(define-module (vcomponent search)
+  :use-module (util)
+  :use-module (ice-9 sandbox)
+  :use-module (srfi srfi-41)
+  :use-module (srfi srfi-41 util)
+  )
+
+
+(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 #\))))
+
+(define-public (prepare-string str)
+  (call-with-input-string (close-parenthese str) read))
+
+(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)
+           ((ice-9 regex) string-match)
+           ;; TODO datetime
+           ,@all-pure-bindings)
+         )))
+
+
+(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 #t
+    (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))))
+    (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
+      '())))