Parser works now.

2 files changed, 129 insertions, 132 deletions

diff --git a/src/main.scm b/src/main.scm
new file mode 100755
index 00000000..efc4e897
--- /dev/null
+++ b/src/main.scm
@@ -0,0 +1,24 @@
+#!/usr/bin/guile \
+-e main -s
+!#
+
+(add-to-load-path (dirname (current-filename)))
+
+(use-modules (parse))
+
+(define (main args)
+
+;; (define *path* "/home/hugo/.local/var/cal/STABEN/599ca4a2f8eda362aaac598c999321dcc8004780a1d5cef36019c7e421b70b08.ics")
+;; (define root (parse-cal-path *path*))
+
+;; (format #t "root = ~a~%" root)
+
+
+  (format (current-error-port) "Parsing ~s~%" (cadr args))
+  (let ((cal (read-vcalendar (cadr args))))
+    (format #t "cal = ~a~%" cal)
+    (format (current-error-port) "~a events~%" (length cal)))
+
+  )
+
+
diff --git a/src/parse.scm b/src/parse.scm
index 3f245002..9b7098b9 100644
--- a/src/parse.scm
+++ b/src/parse.scm
@@ -4,6 +4,7 @@
   :use-module (rnrs bytevectors)
   :use-module (srfi srfi-9)
   :use-module ((ice-9 textual-ports) :select (unget-char))
+  :use-module ((ice-9 ftw) :select (scandir))
 
   )
 
@@ -44,8 +45,9 @@
 (define contexts '(key value param-name param-value escape))
 
 (define-record-type <parse-ctx>
-  (make-parse-ctx% row col ctx line-key param-key param-table)
+  (make-parse-ctx% filename row col ctx line-key param-key param-table)
   parse-ctx?
+  (filename get-filename)
   (row get-row set-row!)
   (col get-col set-col!)
   (ctx get-ctx set-ctx!)
@@ -54,8 +56,8 @@
   (param-table get-param-table set-param-table!)
   )
 
-(define (make-parse-ctx)
-  (make-parse-ctx% 0 0 'key
+(define (make-parse-ctx filename)
+  (make-parse-ctx% filename 1 0 'key
                    #f #f (make-hash-table)))
 
 (define (increment-column! ctx)
@@ -116,140 +118,111 @@
 
           )))
 
-(define (parse-file filename file root)
-  (set-current-input-port file)
-  (let ((component root)
-        (ctx (make-parse-ctx))
-        (strbuf (make-strbuf)))
-    (catch #t
-      (lambda ()
-       (while #t
-         (let ((c (get-u8 (current-input-port))))
-           (cond
-
-            ;; End of file
-            [(eof-object? c)
-             ;; TODO handle final line here
-             (break)]
-
-            ;; End of line
-            [(memv (integer->char c) '(#\return #\newline))
-             (case (fold-proc ctx c)
-               [(error writeback-error) => (lambda (t) (throw t))]
-               [(end-of-line)
-                (let ((str (strbuf->string strbuf)))
-                  (cond [(string=? (get-line-key ctx) "BEGIN")
-                         (let ((child (make-vcomponent (string->symbol str))))
-                           (add-child! component child)
-                           (set! component child))]
-
-                        [(string=? (get-line-key ctx) "END")
-                         (set! component (get-component-parent component))]
-
-                        [else
-                         (let ((ht (get-component-attributes component)))
-                           ;; TODO repeated keys
-                           (hashq-set! ht (string->symbol (get-line-key ctx))
-                                       (cons (get-param-table ctx)
-                                             str))
-                           (set-param-table! ctx (make-hash-table)))])
-
-                  (strbuf-reset! strbuf)
-                  (set-ctx! ctx 'key))])]
-
-            ;; Escaped characters
-            [(char=? (integer->char c) #\\)
-             (let ((cc (integer->char (get-u8 (current-input-port)))))
-               (case cc
-                 ;; Escape character '\' and escaped token sepparated by a newline
-                 ;; (since the standard for some reason allows that (!!!))
-                 ;; We are at least guaranteed that it's a folded line, so just
-                 ;; unfold it and continue trying to find a token to escape.
-                 [(#\return #\newline)
-                  (case (fold-proc ctx cc)
-                    [(end-of-line) (throw 'escape-error "ESC before not folded line")]
-                    [(fold)
-                     (increment-column! ctx)
-                     (strbuf-append! strbuf (get-u8 (current-input-port)))])]
-                 [(#\n #\N)
-                  (strbuf-append! strbuf (char->integer #\newline))]
-                 [(#\; #\, #\\) => (lambda (c) (strbuf-append! strbuf c))]
-                 [else (throw 'escape-error "Non-escapable character" cc)])
-               (increment-column! ctx))]
-
-            ;; Delimiter between param key and param value
-            [(and (eq? (get-ctx ctx) 'panam-name) (char=? (integer->char c) #\=))
-             (set-param-key! ctx (strbuf->string strbuf))
-             (strbuf-reset! strbuf)
-             (set-ctx! ctx 'param-value)]
-
-            ;; Delimiter between parameters (;), or between "something" and attribute value (:)
-            [(memv (integer->char c) '(#\: #\;))
-             (case (get-ctx ctx)
-               [(param-value)
-                (hashq-set! (get-param-table ctx)
-                            (get-param-key ctx)
-                            (strbuf->string strbuf))
-                (strbuf-reset! strbuf)]
-               [(key)
-                (set-line-key! ctx (strbuf->string strbuf))
-                (strbuf-reset! strbuf)])
-             (set-ctx! ctx (case c
-                             [(#\:) 'value]
-                             [(#\;) 'param-name]))]
-
-            ;; Regular character
-            [else
-             (strbuf-append! strbuf c)
-             (increment-column! ctx)
-             ]))))
-
-     (lambda (err . args)
-       (format #t "err = ~a~%ctx = ~a~%args = ~a~%"
-               err ctx args)
-       ))))
+(define (parse-calendar port)
+  (with-input-from-port port
+    (lambda ()
+     (let ((component (make-vcomponent))
+           (ctx (make-parse-ctx (port-filename port)))
+           (strbuf (make-strbuf)))
+       (catch #t
+         (lambda ()
+           (while #t
+             (let ((c (get-u8 (current-input-port))))
+               (cond
+
+                ;; End of file
+                [(eof-object? c)
+                 ;; TODO handle final line here
+                 (break)]
+
+                ;; End of line
+                [(memv (integer->char c) '(#\return #\newline))
+                 (case (fold-proc ctx c)
+                   [(error writeback-error) => (lambda (t) (throw t))]
+                   [(end-of-line)
+                    (let ((str (strbuf->string strbuf)))
+                      (cond [(string=? (get-line-key ctx) "BEGIN")
+                             (let ((child (make-vcomponent (string->symbol str))))
+                               (add-child! component child)
+                               (set! component child))]
+
+                            [(string=? (get-line-key ctx) "END")
+                             (set! component (get-component-parent component))]
+
+                            [else
+                             (let ((ht (get-component-attributes component)))
+                               ;; TODO repeated keys
+                               (hashq-set! ht (string->symbol (get-line-key ctx))
+                                           (cons (get-param-table ctx)
+                                                 str))
+                               (set-param-table! ctx (make-hash-table)))])
+
+                      (strbuf-reset! strbuf)
+                      (set-ctx! ctx 'key))])]
+
+                ;; Escaped characters
+                [(char=? (integer->char c) #\\)
+                 (let ((cc (integer->char (get-u8 (current-input-port)))))
+                   (case cc
+                     ;; Escape character '\' and escaped token sepparated by a newline
+                     ;; (since the standard for some reason allows that (!!!))
+                     ;; We are at least guaranteed that it's a folded line, so just
+                     ;; unfold it and continue trying to find a token to escape.
+                     [(#\return #\newline)
+                      (case (fold-proc ctx cc)
+                        [(end-of-line) (throw 'escape-error "ESC before not folded line")]
+                        [(fold)
+                         (increment-column! ctx)
+                         (strbuf-append! strbuf (get-u8 (current-input-port)))])]
+                     [(#\n #\N)
+                      (strbuf-append! strbuf (char->integer #\newline))]
+                     [(#\; #\, #\\) => (lambda (c) (strbuf-append! strbuf (char->integer c)))]
+                     [else (throw 'escape-error "Non-escapable character" cc)])
+                   (increment-column! ctx))]
+
+                ;; Delimiter between param key and param value
+                [(and (eq? (get-ctx ctx) 'panam-name) (char=? (integer->char c) #\=))
+                 (set-param-key! ctx (strbuf->string strbuf))
+                 (strbuf-reset! strbuf)
+                 (set-ctx! ctx 'param-value)]
+
+                ;; Delimiter between parameters (;), or between "something" and attribute value (:)
+                [(memv (integer->char c) '(#\: #\;))
+                 (case (get-ctx ctx)
+                   [(param-value)
+                    (hashq-set! (get-param-table ctx)
+                                (get-param-key ctx)
+                                (strbuf->string strbuf))
+                    (strbuf-reset! strbuf)]
+                   [(key)
+                    (set-line-key! ctx (strbuf->string strbuf))
+                    (strbuf-reset! strbuf)])
+                 (set-ctx! ctx (case c
+                                 [(#\:) 'value]
+                                 [(#\;) 'param-name]))]
+
+                ;; Regular character
+                [else
+                 (strbuf-append! strbuf c)
+                 (increment-column! ctx)
+                 ])))
+           component)
+
+         (lambda (err . args)
+           (format (current-error-port) "err = ~a~%ctx = ~a~%args = ~s~%"
+                   err ctx args)
+           ))))))
 
 
 
-;;; These parts are more or less taken verbatim (with language trans-
-;;; literation) from calendar.c. The code is horcrible from a scheme
-;;; perspective. TODO replace it with propper code.
-
-(define (open-ics path cal)
-  (define f (open-input-file path))
-  (parse-file path f cal))
-
-(define (handle-dir cal path)
-  'TODO
-  ;; TODO
-  )
-
-(define (handle-file cal path)
-  (set-attribute! cal 'X-HNH-SOURCETYPE "file")
-  (open-ics path cal)
-  )
-
-
-(define (read-vcalendar root path)
+(define-public (read-vcalendar path)
   (define st (stat path))
   (case (stat:type st)
-    [(regular) (handle-file root path)]
-    [(directory) (handle-dir root path)]
+    [(regular) (call-with-input-file path parse-calendar)]
+    [(directory) (map (lambda (fname) (call-with-input-file (string-append path file-name-separator-string fname)
+                                   parse-calendar))
+                      (scandir path (lambda (s) (and (not (string= "." (string-take s 1)))
+                                                (string= "ics" (string-take-right s 3))))))]
     [(block-special char-special fifo socket unknown symlink)
      => (lambda (t) (throw t))])
   )
-
-(define (parse-cal-path path)
-  (define root (make-vcomponent))
-  (read-vcalendar root path)
-  root)
-
-
-
-(define *path* "/home/hugo/.local/var/cal/STABEN/599ca4a2f8eda362aaac598c999321dcc8004780a1d5cef36019c7e421b70b08.ics")
-(define root (parse-cal-path *path*))
-
-(format #t "root = ~a~%" root)
-
-
-