From 6dd5ff6ff9915259cfd23ad757408e1697d852a5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 2 Nov 2019 18:24:30 +0100 Subject: Parser works now. --- src/main.scm | 24 ++++++ src/parse.scm | 237 ++++++++++++++++++++++++++-------------------------------- 2 files changed, 129 insertions(+), 132 deletions(-) create mode 100755 src/main.scm (limited to 'src') 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 - (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) - - - -- cgit v1.2.3