Work on parser port.

1 files changed, 49 insertions, 23 deletions

diff --git a/src/parse.scm b/src/parse.scm
index e5b3ae32..3f245002 100644
--- a/src/parse.scm
+++ b/src/parse.scm
@@ -3,8 +3,10 @@
   :use-module (rnrs io ports)
   :use-module (rnrs bytevectors)
   :use-module (srfi srfi-9)
+  :use-module ((ice-9 textual-ports) :select (unget-char))
 
   )
+
 
 
 (define-record-type <vcomponent>
@@ -22,6 +24,15 @@
   (set-component-children! parent (cons child (get-component-children parent)))
   (set-component-parent! child parent))
 
+(define* (get-attribute-value component key #:optional default)
+  (cond [(hashq-ref (get-component-attributes component)
+                    key #f)
+         => (lambda (p) (cdr p))]
+        [else default]))
+
+(define (get-attribute component key)
+  (hashq-ref (get-component-attributes component) key))
+
 (define (set-attribute! component key value)
   (let ((ht (get-component-attributes component)))
    (cond [(hashq-ref ht key #f)
@@ -30,10 +41,8 @@
 
 
 
-
 (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)
   parse-ctx?
@@ -55,6 +64,7 @@
 (define (increment-row! ctx)
   (set-col! ctx 0)
   (set-row! ctx (1+ (get-row ctx))))
+
 
 
 (define-record-type <strbuf>
@@ -91,24 +101,18 @@
     (increment-row! ctx)
     (cond [(not (= (char->integer #\newline)
                    (car pair)))
-           ;; ERROR expected newline after CR
-            'error
-           ]
+           (throw 'fold-error "Expected newline after CR")]
 
           [(memv (integer->char (cdr pair)) '(#\space #\tab))
            (increment-column! ctx)
-           'fold
-           ]
-
-          #;
-          [ungetc...
-          'writeback-error
-          ]
+           'fold]
 
           [else
-           ;; ...
-           'end-of-line
-           ]
+           ;; TODO check if this failed, and signal a writeback error
+           (unget-char (current-input-port)
+                       (integer->char (cdr pair)))
+
+           'end-of-line]
 
           )))
 
@@ -123,9 +127,12 @@
          (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))]
@@ -150,24 +157,33 @@
                   (strbuf-reset! strbuf)
                   (set-ctx! ctx 'key))])]
 
+            ;; Escaped characters
             [(char=? (integer->char c) #\\)
-             (let ((cc (get-u8 (current-input-port))))
+             (let ((cc (integer->char (get-u8 (current-input-port)))))
                (case cc
-                 [(#\return #\newline) ;; TODO fold?
-                  (fold-proc ctx 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 'err]
-                 )
+                 [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)
@@ -182,17 +198,22 @@
                              [(#\:) '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)
        ))))
 
 
-;;; TODO
+
+;;; 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))
@@ -224,6 +245,11 @@
   root)
 
 
-(define root (parse-cal-path "/home/hugo/.local/var/cal/STABEN/599ca4a2f8eda362aaac598c999321dcc8004780a1d5cef36019c7e421b70b08.ics"))
+
+(define *path* "/home/hugo/.local/var/cal/STABEN/599ca4a2f8eda362aaac598c999321dcc8004780a1d5cef36019c7e421b70b08.ics")
+(define root (parse-cal-path *path*))
 
 (format #t "root = ~a~%" root)
+
+
+