From 04b31c9b820e6756043a87027458c0b8d0546d7b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 1 Nov 2019 21:10:06 +0100 Subject: Start port of parse to scheme. --- Makefile | 6 +- src/parse.c | 2 +- src/parse.scm | 229 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 235 insertions(+), 2 deletions(-) create mode 100644 src/parse.scm diff --git a/Makefile b/Makefile index 2065bda9..9ad9f533 100644 --- a/Makefile +++ b/Makefile @@ -49,7 +49,11 @@ lib/%.so: $(O_FILES) @mkdir -p lib $(CC) -shared -o $@ $^ $(LDFLAGS) -obj/%.scm.go: %.scm # $(SO_FILES) +obj/module/vcomponent/primitive.scm.go: module/vcomponent/primitive.scm $(SO_FILES) + @mkdir -p obj + guild compile $(GUILE_C_FLAGS) -o $@ $< + +obj/%.scm.go: %.scm @mkdir -p obj guild compile $(GUILE_C_FLAGS) -o $@ $< diff --git a/src/parse.c b/src/parse.c index 586a43b4..3edbd874 100644 --- a/src/parse.c +++ b/src/parse.c @@ -18,7 +18,7 @@ BEGIN → key -------------------------------→ ':' → value → CRLF -+-→ EOF | ^ v | - ';' → param-key → ':' → param-value --+ + ';' → param-key → '=' → param-value --+ ^ | +------------------------------------+ diff --git a/src/parse.scm b/src/parse.scm new file mode 100644 index 00000000..e5b3ae32 --- /dev/null +++ b/src/parse.scm @@ -0,0 +1,229 @@ + +(define-module (parse) + :use-module (rnrs io ports) + :use-module (rnrs bytevectors) + :use-module (srfi srfi-9) + + ) + + +(define-record-type + (make-vcomponent% type children parent attributes) + vcomponent? + (type component-type) + (children get-component-children set-component-children!) + (parent get-component-parent set-component-parent!) + (attributes get-component-attributes)) + +(define* (make-vcomponent #:optional (type 'VIRTUAL)) + (make-vcomponent% type '() #f (make-hash-table #x10))) + +(define (add-child! parent child) + (set-component-children! parent (cons child (get-component-children parent))) + (set-component-parent! child parent)) + +(define (set-attribute! component key value) + (let ((ht (get-component-attributes component))) + (cond [(hashq-ref ht key #f) + => (lambda (pair) (set-cdr! pair value))] + [else (hashq-set! ht key (cons (make-hash-table) value))]))) + + + + +(define contexts '(key value param-name param-value escape)) + + +(define-record-type + (make-parse-ctx% row col ctx line-key param-key param-table) + parse-ctx? + (row get-row set-row!) + (col get-col set-col!) + (ctx get-ctx set-ctx!) + (line-key get-line-key set-line-key!) + (param-key get-param-key set-param-key!) + (param-table get-param-table set-param-table!) + ) + +(define (make-parse-ctx) + (make-parse-ctx% 0 0 'key + #f #f (make-hash-table))) + +(define (increment-column! ctx) + (set-col! ctx (1+ (get-col ctx)))) + +(define (increment-row! ctx) + (set-col! ctx 0) + (set-row! ctx (1+ (get-row ctx)))) + + +(define-record-type + (make-strbuf% len bytes) + strbuf? + (len get-length set-length!) + (bytes get-bytes) + ) + +(define (make-strbuf) + (make-strbuf% 0 (make-u8vector #x1000)) + ) + +(define (strbuf->string strbuf) + (let ((bv (make-u8vector (get-length strbuf)))) + (bytevector-copy! (get-bytes strbuf) 0 + bv 0 + (get-length strbuf)) + (bytevector->string bv (native-transcoder)))) ; TODO charset + +(define (strbuf-reset! strbuf) + (set-length! strbuf 0)) + +(define (strbuf-append! strbuf u8) + (u8vector-set! (get-bytes strbuf) + (get-length strbuf) + u8) + (set-length! strbuf (1+ (get-length strbuf)))) + +(define (fold-proc ctx c) + (let ((pair (cons (if (= c (char->integer #\newline)) + c (get-u8 (current-input-port))) + (get-u8 (current-input-port))))) + (increment-row! ctx) + (cond [(not (= (char->integer #\newline) + (car pair))) + ;; ERROR expected newline after CR + 'error + ] + + [(memv (integer->char (cdr pair)) '(#\space #\tab)) + (increment-column! ctx) + 'fold + ] + + #; + [ungetc... + 'writeback-error + ] + + [else + ;; ... + 'end-of-line + ] + + ))) + +(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 + + [(eof-object? c) + (break)] + + [(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))])] + + [(char=? (integer->char c) #\\) + (let ((cc (get-u8 (current-input-port)))) + (case cc + [(#\return #\newline) ;; TODO fold? + (fold-proc ctx cc) + ] + [(#\n #\N) + (strbuf-append! strbuf (char->integer #\newline))] + [(#\; #\, #\\) => (lambda (c) (strbuf-append! strbuf c))] + [else 'err] + ) + (increment-column! ctx))] + + [(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)] + + [(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]))] + + [else + (strbuf-append! strbuf c) + (increment-column! ctx) + ])))) + (lambda (err . args) + (format #t "err = ~a~%ctx = ~a~%args = ~a~%" + err ctx args) + )))) + + +;;; TODO + +(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 st (stat path)) + (case (stat:type st) + [(regular) (handle-file root path)] + [(directory) (handle-dir root path)] + [(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 root (parse-cal-path "/home/hugo/.local/var/cal/STABEN/599ca4a2f8eda362aaac598c999321dcc8004780a1d5cef36019c7e421b70b08.ics")) + +(format #t "root = ~a~%" root) -- cgit v1.2.3