Allow multiple benchmark files.

2 files changed, 53 insertions, 4 deletions

diff --git a/module/calp/benchmark/parse.scm b/module/calp/benchmark/parse.scm
new file mode 100644
index 00000000..68a6d5ff
--- /dev/null
+++ b/module/calp/benchmark/parse.scm
@@ -0,0 +1,47 @@
+(define-module (calp benchmark parse)
+  :use-module (util)
+  :use-module (glob)
+  :use-module (statprof)
+
+  :use-module ((srfi srfi-1) :select (concatenate))
+  :use-module ((ice-9 ftw) :select (scandir))
+
+  )
+
+(define-public (run-benchmark)
+  (define all-calendar-files
+    (statprof
+     (lambda ()
+       (concatenate
+        (map (lambda (path)
+               (map
+                (lambda (fname) (path-append path fname))
+                (scandir path (lambda (s) (and (not (string= "." (string-take s 1)))
+                                          (string= "ics" (string-take-right s 3)))))))
+             (glob "~/.local/var/cal/*"))))))
+
+  (define all-read
+    (statprof
+     (lambda ()
+       (map (lambda ( fullname)
+              (let ((cal (call-with-input-file fullname
+                           (@@ (vcomponent ical parse) read-file))))
+                cal))
+            all-calendar-files))))
+
+  (define tokenized
+    (statprof
+     (lambda ()
+       (map (lambda (one-read)
+              (map (@@ (vcomponent ical parse) tokenize)
+                   one-read))
+            all-read))))
+
+  (define parsed
+    (statprof
+     (lambda ()
+       (map (@@ (vcomponent ical parse) parse) tokenized))))
+
+  (format #t "~a files processed~%"
+          (length parsed))
+  )
diff --git a/module/calp/entry-points/benchmark.scm b/module/calp/entry-points/benchmark.scm
index 0814c44c..8eaf3731 100644
--- a/module/calp/entry-points/benchmark.scm
+++ b/module/calp/entry-points/benchmark.scm
@@ -27,7 +27,9 @@
     (print-arg-help opt-spec)
     (throw 'return))
 
-  (let ((strm (get-event-set global-event-object)))
-    (if (option-ref opts 'enable-output #f)
-        (write (stream->list 1000 strm))
-        (stream->list 1000 strm))))
+
+  (awhen (option-ref opts '() #f)
+         ((module-ref (resolve-module
+                       `(calp benchmark ,@(map string->symbol it)))
+                      'run-benchmark)))
+)