From d00fea566004e67161ee45246b239fff5d416b0e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 21 Dec 2021 16:17:28 +0100 Subject: Cleanup modules. Primarly this moves all vcompenent input and output code to clearly labeled modules, instead of being spread out. At the same time it also removes a handfull of unused procedures. --- module/calp/benchmark/parse.scm | 6 ++-- module/calp/entry-points/benchmark.scm | 4 +-- module/calp/entry-points/convert.scm | 8 ++--- module/calp/entry-points/html.scm | 4 +-- module/calp/entry-points/ical.scm | 2 +- module/calp/entry-points/import.scm | 6 ++-- module/calp/entry-points/server.scm | 3 +- module/calp/entry-points/tidsrapport.scm | 6 ++-- module/calp/html/components.scm | 1 - module/calp/html/vcomponent.scm | 8 ++--- module/calp/html/view/calendar.scm | 8 ++--- module/calp/html/view/calendar/month.scm | 2 +- module/calp/html/view/calendar/week.scm | 2 +- module/calp/html/view/search.scm | 2 +- module/calp/main.scm | 4 +-- module/calp/repl.scm | 2 +- module/calp/server/routes.scm | 20 ++++++------- module/calp/terminal.scm | 9 +++--- module/calp/util.scm | 9 ++++++ module/calp/util/exceptions.scm | 50 +------------------------------- 20 files changed, 56 insertions(+), 100 deletions(-) (limited to 'module/calp') diff --git a/module/calp/benchmark/parse.scm b/module/calp/benchmark/parse.scm index f1be66f5..2d7c7b18 100644 --- a/module/calp/benchmark/parse.scm +++ b/module/calp/benchmark/parse.scm @@ -27,7 +27,7 @@ (display "All read\n") (map (lambda ( fullname) (let ((cal (call-with-input-file fullname - (@@ (vcomponent ical parse) read-file)))) + (@@ (vcomponent formats ical parse) read-file)))) cal)) all-calendar-files)))) @@ -36,7 +36,7 @@ (lambda () (display "Tokenized\n") (map (lambda (one-read) - (map (@@ (vcomponent ical parse) tokenize) + (map (@@ (vcomponent formats ical parse) tokenize) one-read)) all-read)))) @@ -44,7 +44,7 @@ (statprof (lambda () (display "Parsed\n") - (map (@@ (vcomponent ical parse) parse) tokenized)))) + (map (@@ (vcomponent formats 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 851edc59..152a398c 100644 --- a/module/calp/entry-points/benchmark.scm +++ b/module/calp/entry-points/benchmark.scm @@ -5,8 +5,8 @@ :use-module (calp util options) :use-module ((srfi srfi-41) :select (stream->list)) - :use-module ((vcomponent instance methods) :select (get-event-set)) - :autoload (vcomponent instance) (global-event-object) + :use-module ((vcomponent util instance methods) :select (get-event-set)) + :autoload (vcomponent util instance) (global-event-object) :export (main) ) diff --git a/module/calp/entry-points/convert.scm b/module/calp/entry-points/convert.scm index 52ee6b2d..f05b1e7b 100644 --- a/module/calp/entry-points/convert.scm +++ b/module/calp/entry-points/convert.scm @@ -61,11 +61,11 @@ (case (string->symbol from) [(ical) ;; read ical - (@ (vcomponent ical parse) parse-calendar)] + (@ (vcomponent formats ical parse) parse-calendar)] [(xcal) ;; read xcal (compose - (@ (vcomponent xcal parse) sxcal->vcomponent) + (@ (vcomponent formats xcal parse) sxcal->vcomponent) ;; TODO strip *TOP* xml->sxml)] [else (error "")] @@ -76,13 +76,13 @@ [(ical) ;; write ical (lambda (component port) - (display ((@ (vcomponent ical output) component->ical-string) + (display ((@ (vcomponent formats ical output) component->ical-string) component) port))] [(xcal) ;; write xcal (lambda (component port) - (sxml->xml ((@ (vcomponent xcal output) vcomponent->sxcal) + (sxml->xml ((@ (vcomponent formats xcal output) vcomponent->sxcal) component) port))] [else (error "")])) diff --git a/module/calp/entry-points/html.scm b/module/calp/entry-points/html.scm index 39f00979..45e71947 100644 --- a/module/calp/entry-points/html.scm +++ b/module/calp/entry-points/html.scm @@ -14,14 +14,14 @@ :renamer (lambda _ 'render-calendar-wide)) :use-module ((calp html view calendar month) :select (render-calendar-table)) - :use-module ((vcomponent instance methods) + :use-module ((vcomponent util instance methods) :select (get-calendars get-event-set)) :use-module ((sxml simple) :select (sxml->xml)) :use-module ((sxml transformations) :select (href-transformer)) :use-module ((xdg basedir) :prefix xdg-) - :autoload (vcomponent instance) (global-event-object) + :autoload (vcomponent util instance) (global-event-object) ) diff --git a/module/calp/entry-points/ical.scm b/module/calp/entry-points/ical.scm index 15e677b5..0ac01b17 100644 --- a/module/calp/entry-points/ical.scm +++ b/module/calp/entry-points/ical.scm @@ -2,7 +2,7 @@ :export (main) :use-module (calp util) :use-module (calp util options) - :use-module (vcomponent ical output) + :use-module (vcomponent formats ical output) :use-module (ice-9 getopt-long) :use-module (datetime) ) diff --git a/module/calp/entry-points/import.scm b/module/calp/entry-points/import.scm index f25e642f..69c5b687 100644 --- a/module/calp/entry-points/import.scm +++ b/module/calp/entry-points/import.scm @@ -7,9 +7,11 @@ :use-module (srfi srfi-1) ;; TODO FIX ;; :use-module (output vdir) - :use-module ((vcomponent vdir save-delete) :select (save-event)) + :use-module ((vcomponent formats vdir save-delete) :select (save-event)) :use-module (vcomponent) - :autoload (vcomponent instance) (global-event-object) + ;; :use-module ((vcomponent formats ical parse) :select (parse-cal-path)) + :use-module ((vcomponent util parse-cal-path) :select (parse-cal-path)) + :autoload (vcomponent util instance) (global-event-object) ) (define options diff --git a/module/calp/entry-points/server.scm b/module/calp/entry-points/server.scm index a456c292..a7be4afd 100644 --- a/module/calp/entry-points/server.scm +++ b/module/calp/entry-points/server.scm @@ -1,7 +1,6 @@ (define-module (calp entry-points server) :use-module (calp util) :use-module (calp util options) - :use-module (calp util exceptions) :use-module (calp util config) :use-module (srfi srfi-1) @@ -68,7 +67,7 @@ (lambda _ (display "Received SIGUSR1, reloading calendars\n" (current-error-port)) - ((@ (vcomponent instance) reload))))) + ((@ (vcomponent util instance) reload))))) diff --git a/module/calp/entry-points/tidsrapport.scm b/module/calp/entry-points/tidsrapport.scm index 4716ceeb..abdd7aa2 100644 --- a/module/calp/entry-points/tidsrapport.scm +++ b/module/calp/entry-points/tidsrapport.scm @@ -50,8 +50,8 @@ (srfi srfi-1) (vcomponent) (datetime) - (vcomponent instance) - (vcomponent instance methods) + (vcomponent util instance) + (vcomponent util instance methods) (calp util) (ice-9 regex) (ice-9 popen) @@ -66,7 +66,7 @@ (define instances (group-by (compose day as-date (extract 'DTSTART)) (stream->list - ((@ (vcomponent search) execute-query) + ((@ (vcomponent util search) execute-query) (lambda (e) (define d (as-datetime (prop e 'DTSTART))) (define s (date year: year month: month day: 1)) diff --git a/module/calp/html/components.scm b/module/calp/html/components.scm index 1d677c0d..36ec5166 100644 --- a/module/calp/html/components.scm +++ b/module/calp/html/components.scm @@ -1,6 +1,5 @@ (define-module (calp html components) :use-module (calp util) - :use-module (calp util exceptions) :use-module (ice-9 curried-definitions) :use-module (ice-9 match) :export (xhtml-doc) diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm index 3e7cc4dc..2abf370d 100644 --- a/module/calp/html/vcomponent.scm +++ b/module/calp/html/vcomponent.scm @@ -1,11 +1,9 @@ (define-module (calp html vcomponent) :use-module (calp util) - :use-module ((calp util exceptions) :select (warning)) - :use-module (vcomponent) :use-module (srfi srfi-1) - :use-module (srfi srfi-26) :use-module (srfi srfi-41) :use-module ((rnrs io ports) :select (put-bytevector)) + :use-module (vcomponent) :use-module (datetime) :use-module ((text util) :select (add-enumeration-punctuation)) :use-module ((web uri-query) :select (encode-query-parameters)) @@ -16,7 +14,6 @@ :use-module ((crypto) :select (sha256 checksum->string)) :use-module ((xdg basedir) :prefix xdg-) :use-module ((vcomponent recurrence) :select (repeating?)) - :use-module ((vcomponent recurrence internal) :prefix #{rrule:}#) :use-module ((vcomponent datetime output) :select (fmt-time-span format-description @@ -169,7 +166,7 @@ (src ,link)))))))) ;; URI (cond ((and=> (param attach 'FMTTYPE) - (compose (cut string= <> "image" 0 5) car)) + (lambda (p) (string=? (car p) "image" 0 5))) `(img (@ (class "attach") (src ,(value attach))))) (else `(a (@ (class "attach") @@ -289,6 +286,7 @@ "🗎"))))))) +;; TODO possibly unused? (define (repeat-info event) `(div (@ (class "eventtext")) (h2 "Upprepningar") diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index aa311fcb..64fafb3d 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -3,8 +3,6 @@ :use-module (vcomponent) :use-module ((vcomponent datetime) :select (events-between)) - :use-module ((vcomponent build) - :select (vcalendar vevent)) :use-module (datetime) :use-module (calp html components) :use-module ((calp html vcomponent) @@ -26,7 +24,7 @@ :use-module (srfi srfi-41 util) :use-module ((vcomponent recurrence) :select (repeating? generate-recurrence-set)) - :use-module ((vcomponent group) + :use-module ((vcomponent util group) :select (group-stream get-groups-between)) :use-module ((base64) :select (base64encode)) ) @@ -406,6 +404,6 @@ window.default_calendar='~a';" ;; rendered as xcal. (div (@ (style "display:none !important;") (id "xcal-data")) - ,((@ (vcomponent xcal output) ns-wrap) - (map (@ (vcomponent xcal output) vcomponent->sxcal) + ,((@ (vcomponent formats xcal output) ns-wrap) + (map (@ (vcomponent formats xcal output) vcomponent->sxcal) (append regular repeating))))))))) diff --git a/module/calp/html/view/calendar/month.scm b/module/calp/html/view/calendar/month.scm index 02689fd5..6506b0ea 100644 --- a/module/calp/html/view/calendar/month.scm +++ b/module/calp/html/view/calendar/month.scm @@ -12,7 +12,7 @@ events-between)) :use-module ((calp html vcomponent) :select (make-block output-uid)) - :use-module ((vcomponent group) + :use-module ((vcomponent util group) :select (group-stream get-groups-between)) ) diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm index 499de1d6..1714c6c4 100644 --- a/module/calp/html/view/calendar/week.scm +++ b/module/calp/html/view/calendar/week.scm @@ -17,7 +17,7 @@ :select (make-block output-uid) ) ;; :use-module ((calp html components) ;; :select ()) - :use-module ((vcomponent group) + :use-module ((vcomponent util group) :select (group-stream get-groups-between)) ) diff --git a/module/calp/html/view/search.scm b/module/calp/html/view/search.scm index c356baec..b939e7a2 100644 --- a/module/calp/html/view/search.scm +++ b/module/calp/html/view/search.scm @@ -1,7 +1,7 @@ (define-module (calp html view search) :use-module (calp util) :use-module (vcomponent) - :use-module (vcomponent search) + :use-module (vcomponent util search) :use-module ((ice-9 pretty-print) :select (pretty-print)) :use-module ((web uri-query) :select (encode-query-parameters)) :use-module ((calp html components) diff --git a/module/calp/main.scm b/module/calp/main.scm index 1af2861a..a27e4c38 100644 --- a/module/calp/main.scm +++ b/module/calp/main.scm @@ -35,7 +35,7 @@ (description "Start a Guile repl which can be connected to, defaults to the unix socket " (i "/run/user/${UID}/calp-${PID}") ", but it can be bound to any unix or " - "TCP socket. ((@ (vcomponent instance) global-event-object)) " + "TCP socket. ((@ (vcomponent util instance) global-event-object)) " "should contain all events." (br) (b "Should NOT be used in production."))) @@ -260,5 +260,5 @@ ;; and prints them. (map (lambda (it) (with-output-to-port (current-error-port) - (lambda () ((@ (vcomponent describe) describe) it)))) + (lambda () ((@ (vcomponent util describe) describe) it)))) (filter-stack (@ (vcomponent) vcomponent?) (make-stack #t)))))) diff --git a/module/calp/repl.scm b/module/calp/repl.scm index e6fbfe3d..0765b65c 100644 --- a/module/calp/repl.scm +++ b/module/calp/repl.scm @@ -6,7 +6,7 @@ :use-module (system repl server) :use-module (ice-9 regex) :use-module ((calp util hooks) :select (shutdown-hook)) - :use-module (calp util exceptions) + :use-module ((calp util exceptions) :select (warning)) ) (define-public (repl-start address) diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index 08e48714..a435bbc0 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -25,11 +25,11 @@ :use-module (web http make-routes) :use-module (vcomponent) - :use-module (vcomponent search) + :use-module (vcomponent util search) :use-module (datetime) - :use-module (vcomponent ical output) + :use-module (vcomponent formats ical output) - :autoload (vcomponent instance) (global-event-object) + :autoload (vcomponent util instance) (global-event-object) :use-module (calp html view calendar) :use-module ((calp html view search) :select (search-result-page)) @@ -159,7 +159,7 @@ (remove-event global-event-object it) (set! (prop it 'X-HNH-REMOVED) #t) (set! (param (prop* it 'X-HNH-REMOVED) 'VALUE) "BOOLEAN") - (unless ((@ (vcomponent vdir save-delete) save-event) it) + (unless ((@ (vcomponent formats vdir save-delete) save-event) it) (return (build-response code: 500) "Saving event to disk failed.")) (return (build-response code: 204))) @@ -203,7 +203,7 @@ ;; *TOP* node is a required part of the sxml. (let ((event - ((@ (vcomponent xcal parse) sxcal->vcomponent) + ((@ (vcomponent formats xcal parse) sxcal->vcomponent) (catch 'parser-error (lambda () (move-to-namespace @@ -232,7 +232,7 @@ => (lambda (old-event) ;; remove old instance of event from runtime - ((@ (vcomponent instance methods) remove-event) + ((@ (vcomponent util instance methods) remove-event) global-event-object old-event) ;; Add new event to runtime, @@ -252,7 +252,7 @@ ;; save-event sets -X-HNH-FILENAME from the UID. This is fine ;; since the two events are guaranteed to have the same UID. - (unless ((@ (vcomponent vdir save-delete) save-event) event) + (unless ((@ (vcomponent formats vdir save-delete) save-event) event) (return (build-response code: 500) "Saving event to disk failed.")) @@ -266,7 +266,7 @@ ;; created (since we save beforehand). This is just a minor problem ;; which either a better atomic model, or a propper error ;; recovery log would solve. - ((@ (vcomponent vdir save-delete) remove-event) old-event)) + ((@ (vcomponent formats vdir save-delete) remove-event) old-event)) (format (current-error-port) @@ -284,7 +284,7 @@ ;; NOTE Posibly defer save to a later point. ;; That would allow better asyncronous preformance. - (unless ((@ (vcomponent vdir save-delete) save-event) event) + (unless ((@ (vcomponent formats vdir save-delete) save-event) event) (return (build-response code: 500) "Saving event to disk failed.")) @@ -339,7 +339,7 @@ ;; Look into changing how events carry around their ;; parent information, possibly splitting "source parent" ;; and "program parent" into different fields. - (lambda () (sxml->xml ((@ (vcomponent xcal output) vcomponent->sxcal) it))))) + (lambda () (sxml->xml ((@ (vcomponent formats xcal output) vcomponent->sxcal) it))))) (return (build-response code: 404) (format #f "No component with UID=~a found." uid)))) diff --git a/module/calp/terminal.scm b/module/calp/terminal.scm index 4b62895d..1014b94c 100644 --- a/module/calp/terminal.scm +++ b/module/calp/terminal.scm @@ -3,18 +3,17 @@ #:use-module (datetime) #:use-module (srfi srfi-17) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-41) - #:use-module (srfi srfi-41 util) + #:use-module ((srfi srfi-41) :select (stream-car)) #:use-module (calp util) #:use-module (vulgar) #:use-module (vulgar info) #:use-module (vulgar color) #:use-module (vulgar components) - #:use-module (vcomponent group) #:use-module (vcomponent) #:use-module (vcomponent datetime) - #:use-module (vcomponent search) + #:use-module (vcomponent util search) + #:use-module (vcomponent util group) #:use-module (text util) #:use-module (text flow) @@ -28,7 +27,7 @@ #:use-module (oop goops) #:use-module (oop goops describe) - #:autoload (vcomponent instance) (global-event-object) + #:autoload (vcomponent util instance) (global-event-object) #:export (main-loop)) diff --git a/module/calp/util.scm b/module/calp/util.scm index 70091b2e..93e9fd0c 100644 --- a/module/calp/util.scm +++ b/module/calp/util.scm @@ -14,6 +14,7 @@ case* define-many and=>> label print-and-return + begin1 ) #:replace (let* set! define-syntax when unless)) @@ -136,6 +137,14 @@ (let* ((head tail (split-at lst len))) (append head (list tail)))) + +(define-syntax-rule (begin1 first rest ...) + (let ((return first)) + rest ... + return)) + + + (define-macro (print-and-return expr) diff --git a/module/calp/util/exceptions.scm b/module/calp/util/exceptions.scm index 04fc7a67..d9df30ed 100644 --- a/module/calp/util/exceptions.scm +++ b/module/calp/util/exceptions.scm @@ -7,44 +7,7 @@ #:use-module ((system vm frame) :select (frame-bindings binding-ref)) - #:export (throw-returnable - catch-multiple - assert)) - -(define-syntax-rule (throw-returnable symb args ...) - (call/cc (lambda (cont) (throw symb cont args ...)))) - -;; Takes a (non nested) list, and replaces all single underscore -;; symbols with a generated symbol. For macro usage. -(define (multiple-ignore lst) - (map/dotted (lambda (symb) (if (eq? symb '_) (gensym "ignored_") symb)) - lst)) - -;; Like @var{catch}, but multiple handlers can be specified. -;; Each handler is on the form -;; @example -;; [err-symb (args ...) body ...] -;; @end example -;; -;; Only errors with a handler are caught. Error can *not* be given as -;; an early argument. -(define-macro (catch-multiple thunk . cases) - (let catch-recur% ((errs (map car cases)) (cases cases)) - (let* ((v (car errs)) - (case other (partition (lambda (case) (eq? v (car case))) cases)) - (g!rest (gensym "rest"))) - `(catch (quote ,v) - ,(if (null? (cdr errs)) - thunk - `(lambda () ,(catch-recur% (cdr errs) other))) - (lambda (err . ,g!rest) - (apply (lambda ,(let ((param-list (second (car case)))) - (if (not (pair? param-list)) - param-list - (multiple-ignore param-list))) - ,@(cddr (car case))) - ,g!rest)))))) - + #:export (assert)) (define-public warning-handler @@ -81,7 +44,6 @@ [else tree])) - (define-macro (assert form) `(unless ,form (throw 'assertion-error "Assertion failed. ~a expected, ~a got" @@ -89,16 +51,6 @@ ((@@ (calp util exceptions) prettify-tree) (list ,form))))) -(define-syntax catch-warnings - (syntax-rules () - ((_ default body ...) - (parametrize ((warnings-are-errors #t)) - (catch 'warning - (lambda () - body ...) - (lambda _ default)))))) - - (define-public (filter-stack pred? stk) (concatenate (for i in (iota (stack-length stk)) -- cgit v1.2.3