diff options
| author | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-06-23 03:23:44 +0200 |
|---|---|---|
| committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2022-06-23 03:48:22 +0200 |
| commit | 1976980d4a272fb7fc3694c734bfc6825edfc721 (patch) | |
| tree | 8460db1176c64895e9968447588953fac85fe7d6 | |
| parent | Remove all inline use-modules. (diff) | |
| download | calp-1976980d4a272fb7fc3694c734bfc6825edfc721.tar.gz calp-1976980d4a272fb7fc3694c734bfc6825edfc721.tar.xz | |
Centralize (almost) all exports to :export in define-module.
71 files changed, 866 insertions, 510 deletions
diff --git a/module/base64.scm b/module/base64.scm index c0080581..6a3d4706 100644 --- a/module/base64.scm +++ b/module/base64.scm @@ -1,5 +1,4 @@ (define-module (base64) - :use-module ((ice-9 optargs) :select (define*-public)) :use-module ((srfi srfi-71) :select (let*)) :use-module (srfi srfi-88) ; suffix keywords :use-module ((rnrs bytevectors) @@ -12,7 +11,14 @@ bytevector->string make-transcoder latin-1-codec - native-transcoder))) + native-transcoder)) + :export (base64->bytevector + bytevector->base64 + base64-string->bytevector + bytevector->base64-string + base64encode + base64decode + )) (define table (list->vector @@ -49,7 +55,7 @@ bytevector-u8-ref bytevector-u8-set!)) -(define-public (base64->bytevector bv) +(define (base64->bytevector bv) (let ((len* (bytevector-length bv))) (if (zero? len*) (make-bytevector 0) @@ -93,7 +99,7 @@ ret)))) -(define-public (bytevector->base64 bv) +(define (bytevector->base64 bv) (let* ((len (bytevector-length bv)) (iterations rest (floor/ len 3))) (define ret (make-bytevector (+ (* 4 iterations) @@ -137,23 +143,23 @@ ret)) ;; string -> bv -(define-public (base64-string->bytevector string) +(define (base64-string->bytevector string) (base64->bytevector (string->bytevector string (make-transcoder (latin-1-codec))))) ;; bv -> string -(define-public (bytevector->base64-string bv) +(define (bytevector->base64-string bv) (bytevector->string (bytevector->base64 bv) (make-transcoder (latin-1-codec)))) ;; string -> string -(define*-public (base64encode string optional: (transcoder (native-transcoder))) +(define* (base64encode string optional: (transcoder (native-transcoder))) (bytevector->string (bytevector->base64 (string->bytevector string transcoder)) (make-transcoder (latin-1-codec)))) ;; string -> string -(define*-public (base64decode string optional: (transcoder (native-transcoder))) +(define* (base64decode string optional: (transcoder (native-transcoder))) (bytevector->string (base64->bytevector (string->bytevector string (make-transcoder (latin-1-codec)))) diff --git a/module/c/cpp.scm b/module/c/cpp.scm index 3f50fb87..a2935352 100644 --- a/module/c/cpp.scm +++ b/module/c/cpp.scm @@ -11,6 +11,7 @@ :use-module (c lex) :use-module (c parse) :use-module (c operators) + :export (do-funcall replace-symbols include#) ) @@ -31,7 +32,7 @@ (list header-line) #f))) -(define-public (do-funcall function arguments) +(define (do-funcall function arguments) (if (list? arguments) (apply function arguments) (function arguments))) @@ -45,7 +46,7 @@ (!= . (negate =)) )) -(define-public (replace-symbols tree dict) +(define (replace-symbols tree dict) (if (not (list? tree)) (or (assoc-ref dict tree) tree) (map (lambda (node) (replace-symbols node dict)) @@ -139,6 +140,3 @@ `(begin ,@(map (lambda (pair) `(,define-form ,(car pair) ,(cdr pair))) (resolve-dependency-graph graph)))) - - -(export include#) diff --git a/module/c/operators.scm b/module/c/operators.scm index f6fa3da9..ab1b3e7c 100644 --- a/module/c/operators.scm +++ b/module/c/operators.scm @@ -1,4 +1,7 @@ -(define-module (c operators)) +(define-module (c operators) + :export (wordy-binary-operators + symbol-binary-operators + binary-operators)) ;;; Simple operators are those which can be combined with '=' @@ -6,15 +9,15 @@ `(+ - * / & ,(symbol #\|) ^ << >> % < > =)) ;; apparently part of C -(define-public wordy-binary-operators +(define wordy-binary-operators '(bitand and_eq and bitor or_eq or xor_eq xor)) -(define-public symbol-binary-operators +(define symbol-binary-operators (append (map (lambda (x) (symbol-append x '=)) simple-operators) `(&& ,(symbol #\| #\|) != ,(symbol #\,) -> ,(symbol #\.)) simple-operators)) -(define-public binary-operators +(define binary-operators (append symbol-binary-operators wordy-binary-operators)) diff --git a/module/calp/benchmark/parse.scm b/module/calp/benchmark/parse.scm index 1391d18a..2ba8a7de 100644 --- a/module/calp/benchmark/parse.scm +++ b/module/calp/benchmark/parse.scm @@ -3,13 +3,15 @@ :use-module ((hnh util path) :select (path-append)) :use-module (glob) :use-module (statprof) + :use-module (datetime) :use-module ((srfi srfi-1) :select (concatenate)) :use-module ((ice-9 ftw) :select (scandir)) + :export (run-benchmark) ) -(define-public (run-benchmark) +(define (run-benchmark) (define all-calendar-files (statprof (lambda () diff --git a/module/calp/entry-points/server.scm b/module/calp/entry-points/server.scm index 26c2bee7..d357015d 100644 --- a/module/calp/entry-points/server.scm +++ b/module/calp/entry-points/server.scm @@ -34,7 +34,7 @@ and <i>[::]</i> for IPv6</group>")))) (define-config port 8080 description: (_ "Port to which the web server should bind.")) -(define-public (main args) +(define (main args) (define opts (getopt-long args (getopt-opt options))) (define addr (option-ref opts 'addr #f)) diff --git a/module/calp/html/caltable.scm b/module/calp/html/caltable.scm index c8a225a1..efaf8871 100644 --- a/module/calp/html/caltable.scm +++ b/module/calp/html/caltable.scm @@ -6,6 +6,8 @@ :use-module (srfi srfi-41) :use-module (calp translation) + + :export (cal-table) ) ;; Small calendar similar to the one below. @@ -30,7 +32,7 @@ ;; prev-start and next-start will generate links for the next interval, ;; they can't be infered from start and end date, mostly due to months having ;; different lengths -(define*-public (cal-table key: start-date end-date next-start prev-start) +(define* (cal-table key: start-date end-date next-start prev-start) (define (->link date) (date->string date "~Y-~m-~d.html")) diff --git a/module/calp/html/components.scm b/module/calp/html/components.scm index a36dbef9..2b7f58bd 100644 --- a/module/calp/html/components.scm +++ b/module/calp/html/components.scm @@ -3,8 +3,14 @@ :use-module (ice-9 curried-definitions) :use-module (ice-9 match) :use-module (calp translation) - :export (xhtml-doc) - ) + :export (xhtml-doc + slider-input + btn + tabset + include-css + include-alt-css + input-plus-minus + )) ;; Wraps a number of sxml forms into a valid sxhtml-tree. (define-syntax xhtml-doc @@ -20,12 +26,12 @@ ;; Add a slider with an associated number input. Keeps the two in sync. -(define*-public (slider-input key: variable - (min 0) - (max 10) - (step 1) - (value 1) - (unit "")) +(define* (slider-input key: variable + (min 0) + (max 10) + (step 1) + (value 1) + (unit "")) `(slider-input (@ (min ,min) @@ -37,7 +43,7 @@ variable unit))))) ;; Generates a button or button-like link. -(define*-public (btn key: onclick href (class '()) +(define* (btn key: onclick href (class '()) allow-other-keys: rest: args) (when (and onclick href) @@ -80,7 +86,7 @@ ;; @end example ;; Creates a tab with an calendar emoji as icon, "Översikt" is sent as the ;; extra argument #:title, and the body is the return from fmt-single-event. -(define-public (tabset elements) +(define (tabset elements) (define tabgroup (symbol->string (gensym "tabgroup"))) `(div (@ (class "tabgroup")) @@ -110,21 +116,21 @@ ,@inner-body)])) -(define-public (include-css path . extra-attributes) +(define (include-css path . extra-attributes) `(link (@ (type "text/css") (rel "stylesheet") (href ,path) ,@extra-attributes))) -(define-public (include-alt-css path . extra-attributes) +(define (include-alt-css path . extra-attributes) `(link (@ (type "text/css") (rel "alternate stylesheet") (href ,path) ,@extra-attributes))) -(define-public (input-plus-minus positive?) +(define (input-plus-minus positive?) (define id (gensym "id")) `(span (@ (class "input-timespan")) (input (@ (type "checkbox") diff --git a/module/calp/html/util.scm b/module/calp/html/util.scm index affaf5d2..948cadb7 100644 --- a/module/calp/html/util.scm +++ b/module/calp/html/util.scm @@ -1,15 +1,16 @@ (define-module (calp html util) :use-module (hnh util) - :use-module (calp translation)) + :use-module (calp translation) + :export (date-link html-id calculate-fg-color)) -(define-public (date-link date) +(define (date-link date) ((@ (datetime) date->string) date "~Y-~m-~d")) ;; Generate an html id for an event. ;; TODO? same event placed multiple times, when spanning multiple cells -(define-public html-id +(define html-id (let ((id (make-object-property))) (lambda (ev) (or (id ev) @@ -17,7 +18,7 @@ ;; Returns a color with good contrast to the given background color. ;; https://stackoverflow.com/questions/1855884/determine-font-color-based-on-background-color/1855903#1855903 -(define-public (calculate-fg-color c) +(define (calculate-fg-color c) ;; TODO what errors can actually appear here? (catch #t (lambda () diff --git a/module/calp/html/vcomponent.scm b/module/calp/html/vcomponent.scm index 1cee47a5..287c62e1 100644 --- a/module/calp/html/vcomponent.scm +++ b/module/calp/html/vcomponent.scm @@ -25,7 +25,19 @@ :use-module (ice-9 format) :use-module (calp translation) :use-module (calp html filter) - ) + :export (format-summary + format-description + compact-event-list + fmt-single-event + fmt-day + calendar-styles + make-block + output-uid + edit-template + description-template + vevent-edit-rrule-template + popup-template + )) (define (xml-entities s) @@ -34,12 +46,12 @@ (map (lambda (c) (format #f "&#x~x;" (char->integer c))) (string->list s))))) -(define-public (format-summary ev str) +(define (format-summary ev str) ((summary-filter) ev str)) ;; NOTE this should have information about context (html/term/...) ;; And then be moved somewhere else. -(define-public (format-description ev str) +(define (format-description ev str) (catch* (lambda () ((description-filter) ev str)) (configuration-error (lambda (key subr msg args data) @@ -61,7 +73,7 @@ )) ;; used by search view -(define-public (compact-event-list list) +(define (compact-event-list list) (define calendars (delete-duplicates! @@ -101,9 +113,9 @@ ;; Note that the <vevent-description/> tag is bound as a JS custem element, which ;; will re-render all this, through description-template. This also means that ;; the procedures output is intended to be static, and to NOT be changed by JavaScript. -(define*-public (fmt-single-event ev - optional: (attributes '()) - key: (fmt-header list)) +(define* (fmt-single-event ev + optional: (attributes '()) + key: (fmt-header list)) ;; (format (current-error-port) "fmt-single-event: ~a~%" (prop ev 'X-HNH-FILENAME)) `(vevent-description (@ ,@(assq-merge @@ -242,7 +254,7 @@ ;; Single event in side bar (text objects) -(define-public (fmt-day day) +(define (fmt-day day) (let ((date (car day)) (events (cdr day))) `(section (@ (class "text-day")) @@ -272,7 +284,7 @@ ;; Specific styles for each calendar. -(define*-public (calendar-styles calendars optional: (port #f)) +(define* (calendar-styles calendars optional: (port #f)) (format port "~:{ [data-calendar=\"~a\"] { --color: ~a; --complement: ~a }~%~}" (map (lambda (c) (let ((name (base64encode (prop c 'NAME))) @@ -283,7 +295,7 @@ calendars))) ;; "Physical" block in calendar view -(define*-public (make-block ev optional: (extra-attributes '())) +(define* (make-block ev optional: (extra-attributes '())) ;; surrounding <a /> element which allows something to happen when an element ;; is clicked with JS turned off. Our JS disables this, and handles clicks itself. @@ -355,7 +367,7 @@ ;; Return a unique identifier for a specific instance of an event. ;; Allows us to reference each instance of a repeating event separately ;; from any other -(define-public (output-uid event) +(define (output-uid event) (string-concatenate (cons (prop event 'UID) @@ -393,7 +405,7 @@ ;; edit tab of popup -(define-public (edit-template calendars) +(define (edit-template calendars) `(template (@ (id "vevent-edit")) (div (@ (class " eventtext edit-tab ")) @@ -481,7 +493,7 @@ ;; description in sidebar / tab of popup ;; Template data for <vevent-description /> -(define-public (description-template) +(define (description-template) `(template (@ (id "vevent-description")) (div (@ (class " vevent eventtext summary-tab " ())) @@ -532,7 +544,7 @@ ; "2021-09-29 19:56" )))))) -(define-public (vevent-edit-rrule-template) +(define (vevent-edit-rrule-template) `(template (@ (id "vevent-edit-rrule")) (div (@ (class "eventtext")) @@ -588,7 +600,7 @@ ;; Based on popup:s output -(define-public (popup-template) +(define (popup-template) `(template (@ (id "popup-template")) ;; becomes the direct child of <popup-element/> diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm index 8b7d8075..9378737f 100644 --- a/module/calp/html/view/calendar.scm +++ b/module/calp/html/view/calendar.scm @@ -31,6 +31,8 @@ :use-module (ice-9 format) :use-module (calp translation) + + :export (html-generate) ) @@ -49,21 +51,21 @@ ;; TODO document what @var{render-calendar} is supposed to take and return. ;; Can at least note that @var{render-calendar} is strongly encouraged to include ;; (script "const VIEW='??';"), where ?? is replaced by the name of the view. -(define*-public (html-generate - key: - (intervaltype 'all) ; 'week | 'month | 'all - calendars ; All calendars to work on, probably (get-calendars global-event-object) - events ; All events which can be worked on, probably (get-event-set global-event-object) - start-date ; First date in interval to show - end-date ; Last date in interval to show - render-calendar ; (bunch of kv args) → (list sxml) - next-start ; date → date - prev-start ; date → date - ;; The pre and post dates are if we want to show some dates just - ;; outside our actuall interval. Primarily for whole month views, - ;; which needs a bit on each side. - (pre-start start-date) - (post-end end-date)) +(define* (html-generate + key: + (intervaltype 'all) ; 'week | 'month | 'all + calendars ; All calendars to work on, probably (get-calendars global-event-object) + events ; All events which can be worked on, probably (get-event-set global-event-object) + start-date ; First date in interval to show + end-date ; Last date in interval to show + render-calendar ; (bunch of kv args) → (list sxml) + next-start ; date → date + prev-start ; date → date + ;; The pre and post dates are if we want to show some dates just + ;; outside our actuall interval. Primarily for whole month views, + ;; which needs a bit on each side. + (pre-start start-date) + (post-end end-date)) ;; NOTE maybe don't do this again for every month (define evs (get-groups-between (group-stream events) diff --git a/module/calp/html/view/calendar/month.scm b/module/calp/html/view/calendar/month.scm index 1c162aaa..a19fcdb5 100644 --- a/module/calp/html/view/calendar/month.scm +++ b/module/calp/html/view/calendar/month.scm @@ -15,10 +15,11 @@ :select (make-block output-uid)) :use-module ((vcomponent util group) :select (group-stream get-groups-between)) + :export (render-calendar-table) ) ;; (stream event-group) -> sxml -(define*-public (render-calendar-table key: events start-date end-date pre-start post-end #:allow-other-keys) +(define* (render-calendar-table key: events start-date end-date pre-start post-end #:allow-other-keys) (define-values (long-events short-events) ;; TODO should be really-long-event? or event-spanning-midnight diff --git a/module/calp/html/view/calendar/shared.scm b/module/calp/html/view/calendar/shared.scm index 108f3b9a..41d96171 100644 --- a/module/calp/html/view/calendar/shared.scm +++ b/module/calp/html/view/calendar/shared.scm @@ -15,7 +15,11 @@ :select (make-block format-summary)) :use-module (ice-9 format) :use-module (calp translation) - ) + + :export (fix-event-widths! + lay-out-long-events + create-top-block + )) @@ -25,7 +29,7 @@ ;; Takes a list of vcomponents, sets their widths and x-positions to optimally ;; fill out the space, without any overlaps. -(define*-public (fix-event-widths! lst key: event-length-key (event-length-comperator date/-time>?)) +(define* (fix-event-widths! lst key: event-length-key (event-length-comperator date/-time>?)) ;; The tree construction is greedy. This means ;; that if a smaller event preceeds a longer ;; event it would capture the longer event to @@ -51,7 +55,7 @@ (inner x (right-subtree tree)))))) -(define-public (lay-out-long-events start end events) +(define (lay-out-long-events start end events) (fix-event-widths! events event-length-key: event-length event-length-comperator: date/-time>) (map (lambda (e) (create-top-block start end e)) @@ -61,7 +65,7 @@ ;; get hours. This means that a day is always assumed to be 24h, even when that's ;; wrong. This might lead to some weirdness when the timezon switches (DST), but it ;; makes everything else behave MUCH better. -(define-public (create-top-block start-date end-date ev) +(define (create-top-block start-date end-date ev) (define total-length (* 24 (days-in-interval start-date end-date))) diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm index 78abcfbf..828dce41 100644 --- a/module/calp/html/view/calendar/week.scm +++ b/module/calp/html/view/calendar/week.scm @@ -22,10 +22,11 @@ :use-module ((vcomponent util group) :select (group-stream get-groups-between)) :use-module (ice-9 format) + :export (render-calendar) ) -(define*-public (render-calendar key: calendars events start-date end-date #:allow-other-keys) +(define* (render-calendar key: calendars events start-date end-date #:allow-other-keys) (let* ((long-events short-events (partition long-event? (stream->list (events-between start-date end-date events)))) (range (date-range start-date end-date))) `((script ,(lambda () (format #t "window.VIEW='week';"))) diff --git a/module/calp/html/view/search.scm b/module/calp/html/view/search.scm index 08436bc5..114541ed 100644 --- a/module/calp/html/view/search.scm +++ b/module/calp/html/view/search.scm @@ -9,6 +9,7 @@ :use-module ((calp html vcomponent) :select (compact-event-list)) :use-module (calp translation) + :export (search-result-page) ) ;; Display the result of a search term, but doesn't do any searching @@ -21,8 +22,8 @@ ;; @var{search-result} : The list of matched events ;; @var{page} : Which page we are on ;; @var{paginator} : A paginator object -(define-public (search-result-page - errors has-query? search-term search-result page paginator) +(define (search-result-page + errors has-query? search-term search-result page paginator) (xhtml-doc (@ (lang sv)) (head (title ,(_ "Search results")) diff --git a/module/calp/html/view/small-calendar.scm b/module/calp/html/view/small-calendar.scm index 80cbbaf2..4d40c57c 100644 --- a/module/calp/html/view/small-calendar.scm +++ b/module/calp/html/view/small-calendar.scm @@ -2,9 +2,10 @@ :use-module ((calp html components) :select (xhtml-doc include-css)) :use-module ((calp html caltable) :select (cal-table)) :use-module ((datetime) :select (month- month+ remove-day date->string)) + :export (render-small-calendar) ) -(define-public (render-small-calendar month standalone) +(define (render-small-calendar month standalone) (define table (cal-table start-date: month end-date: (remove-day (month+ month)) diff --git a/module/calp/main.scm b/module/calp/main.scm index 7f2a4679..d97d3d76 100644 --- a/module/calp/main.scm +++ b/module/calp/main.scm @@ -29,6 +29,7 @@ :use-module (calp translation) + :export (main) ) @@ -207,7 +208,7 @@ zoneinfo database, but is currently broken.</p>") -(define-public (main args) +(define (main args) ((@ (calp util time) report-time!) (_ "Program start")) (with-throw-handler #t (lambda () diff --git a/module/calp/repl.scm b/module/calp/repl.scm index 6f2c7c0a..7beee560 100644 --- a/module/calp/repl.scm +++ b/module/calp/repl.scm @@ -8,9 +8,10 @@ :use-module ((calp util hooks) :select (shutdown-hook)) :use-module ((hnh util exceptions) :select (warning)) :use-module (calp translation) + :export (repl-start) ) -(define-public (repl-start address) +(define (repl-start address) (define lst (string->list address)) (format (current-error-port) (_ "Starting REPL server at ~a~%") address) diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index 3d90cc04..74836a42 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -40,6 +40,7 @@ :use-module ((calp html components) :select (xhtml-doc include-css)) + :export (make-make-routes) ) @@ -128,7 +129,7 @@ ;; TODO ensure encoding on all fields which take user provided data. ;; Possibly a fallback which strips everything unknown, and treats ;; the bytevector as ascii. -(define-public (make-make-routes) +(define (make-make-routes) (make-routes ;; Manual redirect to not reserve root. diff --git a/module/calp/server/server.scm b/module/calp/server/server.scm index b9d5c6d3..814aaed7 100644 --- a/module/calp/server/server.scm +++ b/module/calp/server/server.scm @@ -1,9 +1,10 @@ (define-module (calp server server) - :use-module (hnh util) :use-module (web server) :use-module ((calp server routes) :select (make-make-routes)) - :use-module (ice-9 threads)) + :use-module (ice-9 threads) + + :export (start-server)) ;; NOTE The default make-default-socket is broken for IPv6. ;; A patch has been submitted to the mailing list. 2020-03-31 @@ -22,7 +23,7 @@ ;; (define server (open-server impl open-params)) -(define-public (start-server open-params) +(define (start-server open-params) (run-server handler 'http open-params 1) ;; NOTE at first this seems to work, but it quickly deteriorates. ;; (for i in (iota 16) diff --git a/module/calp/terminal.scm b/module/calp/terminal.scm index 7cf354d8..e74c5fb8 100644 --- a/module/calp/terminal.scm +++ b/module/calp/terminal.scm @@ -322,7 +322,7 @@ (current-page this)))) (else (next-method)))) -(define-public (main-loop date) +(define (main-loop date) (define state (list (day-view (get-event-set global-event-object) date))) (while #t diff --git a/module/datetime.scm b/module/datetime.scm index 48f5042d..de1495ec 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -1,7 +1,4 @@ (define-module (datetime) - :export (date? year month day - hour minute second - time? datetime?) ;; To resolve colision with cadr-second from srfi-1 :replace (second) @@ -11,7 +8,7 @@ :use-module (srfi srfi-71) :use-module ((hnh util) - :select (vector-last define*-public set! -> ->> swap case* set + :select (vector-last set! -> ->> swap case* set span-upto set->)) :use-module (srfi srfi-41) @@ -19,6 +16,121 @@ :use-module (ice-9 format) :use-module (ice-9 regex) :use-module (calp util config) + + :export (date + date? + year month day + + time + time? + hour minute second + + datetime + datetime? + get-date + get-timezone + + datetime->unix-time + unix-time->datetime + + current-datetime + current-date + + get-datetime + as-date + as-time + as-datetime + + date-zero? + time-zero? + + leap-year? + days-in-month + days-in-year + + start-of-month + end-of-month + start-of-year + end-of-year + + date-stream + day-stream + month-stream + week-stream + + time-min + time-max + date-min + date-max + datetime-min + datetime-max + + month+ + month- + + week-day + week-1-start + week-number + date-starting-week + week-day-name + + timespan-overlaps? + find-first-week-day + all-wday-in-month + all-wday-in-year + add-day + remove-day + in-date-range? + + weekday-list + start-of-week + end-of-week + month-days + days-in-interval + year-day + + time->decimal-hour + datetime->decimal-hour + + date-range + + datetime->string + date->string + time->string + + parse-month + string->datetime + string->time + string->date + string->date/-time + parse-ics-date + parse-ics-time + parse-ics-datetime + parse-iso-date + parse-iso-time + parse-iso-datetime + + parse-freeform-date + + date= date=? + time= time=? + datetime= datetime=? + + date< date<? date<= date<=? + date> date>? date>= date>=? + time< time<? time<= time<=? + time> time>? time>= time>=? + datetime< datetime<? datetime<= datetime<=? + datetime> datetime>? datetime>= datetime>=? + date/-time< date/-time<? date/-time<= date/-time<=? + date/-time> date/-time>? date/-time>= date/-time>=? + + date+ date- + time+ time- + datetime+ datetime- + date-difference + datetime-difference + ) :re-export (locale-month locale-month-short)) @@ -64,7 +176,7 @@ date? (year year) (month month) (day day)) -(define*-public (date key: (year 0) (month 0) (day 0)) +(define* (date key: (year 0) (month 0) (day 0)) (unless (and (integer? year) (integer? month) (integer? day)) (scm-error 'wrong-type-arg "date" "Year, month, and day must all be integers. ~s, ~s, ~s" @@ -89,7 +201,7 @@ time? (hour hour) (minute minute) (second second)) -(define*-public (time key: (hour 0) (minute 0) (second 0)) +(define* (time key: (hour 0) (minute 0) (second 0)) (make-time hour minute second)) (set-record-type-printer! @@ -112,17 +224,15 @@ (tz tz) ; #f for localtime, "UTC", "Europe/Stockholm", ... ) -(export get-date) - -(define-public (get-timezone datetime) +(define (get-timezone datetime) (tz datetime)) -(define*-public (datetime - key: date time - (year 0) (month 0) (day 0) - (hour 0) (minute 0) (second 0) - tz) +(define* (datetime + key: date time + (year 0) (month 0) (day 0) + (hour 0) (minute 0) (second 0) + tz) (make-datetime (or date (make-date year month day)) (or time (make-time hour minute second)) tz)) @@ -170,13 +280,13 @@ tz: (tm:zone tm))) -(define-public (datetime->unix-time dt) +(define (datetime->unix-time dt) (let ((tm (datetime->tm dt))) (car (if (tz dt) (mktime tm (vector-last tm)) (mktime tm))))) -(define-public (unix-time->datetime n) +(define (unix-time->datetime n) ;; tm->datetime returns GMT here (as hinted by the ;; name @var{gmtime}). Blindly change it to UTC. (set (tz (tm->datetime (gmtime n))) @@ -184,10 +294,10 @@ ;; this returns UTC time, with a TZ component set to "UTC" -(define-public (current-datetime) +(define (current-datetime) (unix-time->datetime ((@ (guile) current-time)))) -(define-public (current-date) +(define (current-date) (get-date (current-datetime))) @@ -198,7 +308,7 @@ ;; (as defined by the environment variable TZ). ;; This means that given UTC 10:00 new years day ;; would return 11:00 new years day if ran in sweden. -(define-public (get-datetime dt) +(define (get-datetime dt) (let ((v (datetime->tm dt))) (let ((tm (localtime ; localtime convertion since the returned tm object is @@ -209,7 +319,7 @@ ;; strip tz-name, to conform with my local time. (set (tz (tm->datetime tm)) #f)))) -(define-public (as-date date/-time) +(define (as-date date/-time) (cond [(datetime? date/-time) (get-date date/-time)] [(date? date/-time) date/-time] [(time? date/-time) (date)] @@ -219,7 +329,7 @@ (list date/-time) #f)])) -(define-public (as-time date/-time) +(define (as-time date/-time) (cond [(datetime? date/-time) (get-time% date/-time)] [(date? date/-time) (time)] [(time? date/-time) date/-time] @@ -228,7 +338,7 @@ (list date/-time) #f)])) -(define-public (as-datetime dt) +(define (as-datetime dt) (cond [(datetime? dt) dt] [(date? dt) (datetime date: dt time: (time))] [(time? dt) (datetime time: dt date: (date))] @@ -239,20 +349,20 @@ -(define-public (date-zero? date) +(define (date-zero? date) (= 0 (year date) (month date) (day date))) -(define-public (time-zero? time) +(define (time-zero? time) (= 0 (hour time) (minute time) (second time))) ;; int -> bool -(define-public (leap-year? year) +(define (leap-year? year) (and (zero? (remainder year 4)) (or (zero? (remainder year 400)) (not (zero? (remainder year 100)))))) ;; Returns number of days month for a given date. Just looks at the year and month components. -(define-public (days-in-month date) +(define (days-in-month date) (case* (month date) ((jan mar may jul aug oct dec) 31) ((apr jun sep nov) 30) @@ -264,56 +374,56 @@ (list (month date) date) #f)))) -(define-public (days-in-year date) +(define (days-in-year date) (if (leap-year? (year date)) 366 365)) -(define-public (start-of-month date) +(define (start-of-month date) (set (day date) 1)) -(define-public (end-of-month date) +(define (end-of-month date) (set (day date) (days-in-month date))) -(define-public (start-of-year date) +(define (start-of-year date) (set-> date (day 1) (month 1))) -(define-public (date-stream date-increment start-day) +(define (date-stream date-increment start-day) (stream-iterate (lambda (d) (date+ d date-increment)) start-day)) -(define-public (day-stream start-day) +(define (day-stream start-day) (date-stream (date day: 1) start-day)) -(define-public (month-stream start-day) +(define (month-stream start-day) (date-stream (date month: 1) start-day)) -(define-public (week-stream start-day) +(define (week-stream start-day) (date-stream (date day: 7) start-day)) -(define-public (time-min a b) +(define (time-min a b) (if (time<? a b) a b)) -(define-public (time-max a b) +(define (time-max a b) (if (time<? a b) b a)) -(define-public (date-min a b) +(define (date-min a b) (if (date< a b) a b)) -(define-public (date-max a b) +(define (date-max a b) (if (date< a b) b a)) -(define-public (datetime-min a b) +(define (datetime-min a b) (if (datetime< a b) a b)) -(define-public (datetime-max a b) +(define (datetime-max a b) (if (datetime< a b) b a)) -(define*-public (month+ date-object #:optional (change 1)) +(define* (month+ date-object #:optional (change 1)) (date+ date-object (date month: change))) -(define*-public (month- date-object #:optional (change 1)) +(define* (month- date-object #:optional (change 1)) (date- date-object (date month: change))) ;; https://projecteuclid.org/euclid.acta/1485888738 @@ -334,7 +444,7 @@ 7)) ;; 0 indexed, starting at sunday. -(define-public (week-day date) +(define (week-day date) (let ((J K (floor/ (year date) 100)) (m (month date))) (if (memv m '(1 2)) @@ -348,7 +458,7 @@ ;; (week-1-start #2020-01-01 mon) ;; ⇒ 2019-12-30 ;; @end example -(define*-public (week-1-start d optional: (wkst (week-start))) +(define* (week-1-start d optional: (wkst (week-start))) (let* ((ystart (start-of-year d)) (day-index (modulo (- (week-day ystart) wkst) 7))) (if (> day-index 3) @@ -357,7 +467,7 @@ ;; (week-number #2020-01-01 mon) ; => 1 ;; (week-number #2019-12-31 mon) ; => 1 -(define*-public (week-number d optional: (wkst (week-start))) +(define* (week-number d optional: (wkst (week-start))) ;; Calculating week number for starts of week was much simpler. ;; We can both skip the special cases for Jan 1, 2 & 3. It also ;; solved some weird bug that was here before. @@ -376,15 +486,15 @@ 7))) (1+ week))]))) -(define*-public (date-starting-week - week-number d - optional: (wkst (week-start))) +(define* (date-starting-week + week-number d + optional: (wkst (week-start))) (date+ (week-1-start d wkst) (date day: (* (1- week-number) 7)))) -(define*-public (week-day-name week-day-number optional: truncate-to - key: (locale %global-locale)) +(define* (week-day-name week-day-number optional: truncate-to + key: (locale %global-locale)) ;; NOTE this allows days larger than 7 (sunday if counting from monday). (let ((str (locale-day (1+ (modulo week-day-number 7)) locale))) @@ -408,7 +518,7 @@ ;; @end verbatim ;; ;; E is covered by both case A and B. -(define-public (timespan-overlaps? s1-begin s1-end s2-begin s2-end) +(define (timespan-overlaps? s1-begin s1-end s2-begin s2-end) "Return whetever or not two timespans overlap." (or ;; A @@ -437,7 +547,7 @@ ;; (find-first-week-day mon #2020-04-30) ;; => #2020-05-04 ;; @end example -(define-public (find-first-week-day wday d) +(define (find-first-week-day wday d) (let* ((start-day (week-day d)) (diff (- wday start-day))) (date+ d (date day: (modulo diff 7))))) @@ -451,26 +561,26 @@ ;; => (#2020-06-15 #2020-06-22 #2020-06-29) ;; @end example ;; week-day, date → (list date) -(define-public (all-wday-in-month wday month-date) +(define (all-wday-in-month wday month-date) (stream->list (stream-take-while (lambda (d) (= (month d) (month month-date))) (week-stream (find-first-week-day wday month-date))))) -(define-public (all-wday-in-year wday year-date) +(define (all-wday-in-year wday year-date) (stream->list (stream-take-while (lambda (d) (= (year d) (year year-date))) (week-stream (find-first-week-day wday year-date))))) -(define-public (add-day d) +(define (add-day d) (date+ d (date day: 1))) -(define-public (remove-day d) +(define (remove-day d) (date- d (date day: 1))) -(define-public (in-date-range? start-date end-date) +(define (in-date-range? start-date end-date) (lambda (date) (date<= start-date date end-date))) @@ -480,21 +590,21 @@ ;; (weekday-list sun) ;; => (0 1 2 3 4 5 6) ;; @end exampl -(define*-public (weekday-list optional: (week-start (week-start))) +(define* (weekday-list optional: (week-start (week-start))) (take (drop (apply circular-list (iota 7)) week-start) 7)) ;; returns the date the week containing d started. ;; (start-of-week #2020-04-02 sun) ; => 2020-03-29 -(define*-public (start-of-week d optional: (week-start (week-start))) +(define* (start-of-week d optional: (week-start (week-start))) (date- d (date day: (modulo (- (week-day d) week-start) 7)))) ;; (end-of-week #2020-04-01 mon) ;; => 2020-04-05 -(define*-public (end-of-week d optional: (week-start (week-start))) +(define* (end-of-week d optional: (week-start (week-start))) (date+ (start-of-week d week-start) (date day: 6))) @@ -520,7 +630,7 @@ ;; ; ⇒ (2020-04-01 ... 2020-04-05) ;; @end lisp ;; Ignores day component of @var{date}. -(define*-public (month-days date optional: (week-start (week-start))) +(define* (month-days date optional: (week-start (week-start))) (let* ((month-len (days-in-month date)) (prev-month-len (days-in-month (month- date))) (month-start (modulo (- (week-day date) week-start) 7))) @@ -533,7 +643,7 @@ ;; The amount of days in the given interval, both end pointts inclusive -(define-public (days-in-interval start-date end-date) +(define (days-in-interval start-date end-date) (let ((diff (date-difference (date+ end-date (date day: 1)) start-date))) (->> (month-stream start-date) (stream-take (+ (month diff) @@ -544,19 +654,19 @@ ;; Day from start of the year, so 1 feb would be day 32. ;; Also known as Julian day. -(define-public (year-day date) +(define (year-day date) (days-in-interval (start-of-year date) date)) ;; @example ;; (time->decimal-hour #10:30:00) ; => 10.5 ;; @end example -(define-public (time->decimal-hour time) +(define (time->decimal-hour time) (exact->inexact (+ (hour time) (/ (minute time) 60) (/ (second time) 3600)))) -(define*-public (datetime->decimal-hour dt optional: start-date) +(define* (datetime->decimal-hour dt optional: start-date) (let ((date-diff (cond [start-date @@ -575,7 +685,7 @@ ;; Returns a list of all dates from start to end. ;; both inclusive ;; date, date → [list date] -(define*-public (date-range start end optional: (increment (date day: 1))) +(define* (date-range start end optional: (increment (date day: 1))) (stream->list (stream-take-while (lambda (d) (date<= d end)) (date-stream increment start)))) @@ -583,10 +693,10 @@ ;;; Output -(define*-public (datetime->string - datetime - optional: (fmt "~Y-~m-~dT~H:~M:~S") - key: allow-unknown?) +(define* (datetime->string + datetime + optional: (fmt "~Y-~m-~dT~H:~M:~S") + key: allow-unknown?) (define date (get-date datetime)) (define time (get-time% datetime)) (with-output-to-string @@ -625,13 +735,13 @@ #f (string->list fmt))))) -(define*-public (date->string date +(define* (date->string date optional: (fmt "~Y-~m-~d") key: allow-unknown?) (datetime->string (datetime date: date) fmt allow-unknown?: allow-unknown?)) -(define*-public (time->string time +(define* (time->string time optional: (fmt "~H:~M:~S") key: allow-unknown?) (datetime->string (datetime time: time) @@ -641,7 +751,7 @@ ;;; Input -(define*-public (parse-month str optional: (locale %global-locale)) +(define* (parse-month str optional: (locale %global-locale)) "Get month number from a (shortened) monthname. Returns -1 on failure" (or @@ -656,7 +766,7 @@ Returns -1 on failure" -1)) -(define*-public (string->datetime str optional: (fmt "~Y-~m-~dT~H:~M:~S~Z") +(define* (string->datetime str optional: (fmt "~Y-~m-~dT~H:~M:~S~Z") (locale %global-locale)) (let loop* ((str (string->list str)) (fmt (string->list fmt)) @@ -794,15 +904,15 @@ Returns -1 on failure" (list (car fmt) (car str)) #f))]))) -(define*-public (string->time str optional: (fmt "~H:~M:~S") (locale %global-locale)) +(define* (string->time str optional: (fmt "~H:~M:~S") (locale %global-locale)) (get-time% (string->datetime str fmt locale))) -(define*-public (string->date str optional: (fmt "~Y-~m-~d") (locale %global-locale)) +(define* (string->date str optional: (fmt "~Y-~m-~d") (locale %global-locale)) (get-date (string->datetime str fmt locale))) ;; Parse @var{string} as either a date, time, or date-time. ;; String MUST be on iso-8601 format. -(define-public (string->date/-time string) +(define (string->date/-time string) (define (contains symb) (lambda (string) (string-contains string symb))) @@ -811,28 +921,28 @@ Returns -1 on failure" [string (contains "-") => string->date])) -(define-public (parse-ics-date str) +(define (parse-ics-date str) (string->date str "~Y~m~d")) -(define-public (parse-ics-time str) +(define (parse-ics-time str) (string->time str "~H~M~S")) -(define*-public (parse-ics-datetime str optional: zone) +(define* (parse-ics-datetime str optional: zone) (let ((dt (string->datetime str "~Y~m~dT~H~M~S~Z"))) (if (tz dt) dt (set (tz dt) zone)))) -(define-public (parse-iso-date str) +(define (parse-iso-date str) (string->date str)) -(define-public (parse-iso-time str) +(define (parse-iso-time str) (string->time str)) -(define-public (parse-iso-datetime str) +(define (parse-iso-datetime str) (string->datetime str)) -(define-public (parse-freeform-date str) +(define (parse-freeform-date str) (parse-iso-datetime str)) (define (date->sexp d) @@ -868,7 +978,7 @@ Returns -1 on failure" ;;; EQUIALENCE -(define-public (date= . args) +(define (date= . args) (reduce (lambda (a b) (and b ; did a previous iteration return false? (= (year a) (year b)) @@ -878,7 +988,7 @@ Returns -1 on failure" a)) #t args)) -(define-public (time= . args) +(define (time= . args) (reduce (lambda (a b) (and b (= (hour a) (hour b)) @@ -887,16 +997,16 @@ Returns -1 on failure" a)) #t args)) -(define-public (datetime= . args) +(define (datetime= . args) (reduce (lambda (a b) (and (date= (get-date a) (get-date b)) (time= (get-time% a) (get-time% b)) a)) #t args)) -(define-public date=? date=) -(define-public time=? time=) -(define-public datetime=? datetime=) +(define date=? date=) +(define time=? time=) +(define datetime=? datetime=) (define (date<% a b) (let ((ay (year a)) @@ -909,7 +1019,7 @@ Returns -1 on failure" (< am bm))) (< ay by)))) -(define-public date< +(define date< (case-lambda [() #t] [(_) #t] @@ -921,7 +1031,7 @@ Returns -1 on failure" (or (date= a b) (date< a b))) -(define-public date<= +(define date<= (case-lambda [() #t] [(_) #t] @@ -929,7 +1039,7 @@ Returns -1 on failure" (and (date<=% first second) (apply date<= second rest))])) -(define-public (time< a b) +(define (time< a b) (let ((ah (hour a)) (bh (hour b))) (if (= ah bh) @@ -940,63 +1050,63 @@ Returns -1 on failure" (< am bm))) (< ah bh)))) -(define-public (time<= a b) +(define (time<= a b) (or (time= a b) (time< a b))) -(define-public (datetime< a b) +(define (datetime< a b) (if (date= (get-date a) (get-date b)) (time< (get-time% a) (get-time% b)) (date< (get-date a) (get-date b)))) -(define-public (datetime<= a b) +(define (datetime<= a b) (if (date= (get-date a) (get-date b)) (time<= (get-time% a) (get-time% b)) (date<= (get-date a) (get-date b)))) -(define-public (date/-time< a b) +(define (date/-time< a b) (datetime< (as-datetime a) (as-datetime b))) -(define-public date<? date<) +(define date<? date<) -(define-public date> (swap date<)) -(define-public date>? (swap date<)) +(define date> (swap date<)) +(define date>? (swap date<)) -(define-public date<=? date<=) +(define date<=? date<=) -(define-public date>= (swap date<=)) -(define-public date>=? (swap date<=)) +(define date>= (swap date<=)) +(define date>=? (swap date<=)) -(define-public time<? time<) +(define time<? time<) -(define-public time> (swap time<)) -(define-public time>? (swap time<)) +(define time> (swap time<)) +(define time>? (swap time<)) -(define-public time<=? time<=) +(define time<=? time<=) -(define-public time>= (swap time<=)) -(define-public time>=? (swap time<=)) +(define time>= (swap time<=)) +(define time>=? (swap time<=)) -(define-public datetime<? datetime<) +(define datetime<? datetime<) -(define-public datetime> (swap datetime<)) -(define-public datetime>? (swap datetime<)) +(define datetime> (swap datetime<)) +(define datetime>? (swap datetime<)) -(define-public datetime<=? datetime<=) +(define datetime<=? datetime<=) -(define-public datetime>= (swap datetime<=)) -(define-public datetime>=? (swap datetime<=)) +(define datetime>= (swap datetime<=)) +(define datetime>=? (swap datetime<=)) -(define-public date/-time<? date/-time<) +(define date/-time<? date/-time<) -(define-public date/-time> (swap date/-time<)) -(define-public date/-time>? (swap date/-time<)) +(define date/-time> (swap date/-time<)) +(define date/-time>? (swap date/-time<)) -(define-public date/-time<= (negate date/-time>)) -(define-public date/-time<=? (negate date/-time>)) +(define date/-time<= (negate date/-time>)) +(define date/-time<=? (negate date/-time>)) -(define-public date/-time>= (negate date/-time<)) -(define-public date/-time>=? (negate date/-time<)) +(define date/-time>= (negate date/-time<)) +(define date/-time>=? (negate date/-time<)) @@ -1070,7 +1180,7 @@ Returns -1 on failure" ;; @var{base} MUST be a valid real date. all rest arguments can however ;; be "invalid" dates, such as 0000-00-10 -(define-public (date+ base . rest) +(define (date+ base . rest) (fold date+% base rest)) (define (date-%% change base) @@ -1125,7 +1235,7 @@ Returns -1 on failure" ) ;;; Only use this with extreme caution -(define-public (date- base . rest) +(define (date- base . rest) (fold date-% base rest)) ;;; time @@ -1162,7 +1272,7 @@ Returns -1 on failure" (values hour-almost-fixed 0))) ;;; PLUS -(define-public (time+ base . rest) +(define (time+ base . rest) (let ((sum 0)) (let ((time (fold (lambda (next done) (let ((next-time rem (time+% done next))) @@ -1212,7 +1322,7 @@ Returns -1 on failure" ;; (time- #10:00:00 (time hour: 48)) ; => 10:00:00 => 2 ;; (time- #10:00:00 (time hour: (+ 48 4))) ; => 06:00:00 => 2 ;; @end lisp -(define-public (time- base . rest) +(define (time- base . rest) (let ((sum 0)) (let ((time (fold (lambda (next done) (let ((next-time rem (time-% done next))) @@ -1225,7 +1335,7 @@ Returns -1 on failure" ;;; DATETIME -(define-public (datetime+ base change) +(define (datetime+ base change) (let ((time overflow (time+ (get-time% base) (get-time% change)))) (datetime date: (date+ (get-date base) (get-date change) @@ -1234,7 +1344,7 @@ Returns -1 on failure" tz: (get-timezone base) ))) -(define-public (datetime- base change) +(define (datetime- base change) (let ((time underflow (time- (get-time% base) (get-time% change)))) (datetime date: (date- (get-date base) (get-date change) @@ -1288,7 +1398,7 @@ Returns -1 on failure" ;; NOTE, this is only properly defined when b is greater than a. -(define-public (date-difference b a) +(define (date-difference b a) (when (or (negative? (month b)) (negative? (day b)) (negative? (month a)) @@ -1307,7 +1417,7 @@ Returns -1 on failure" ;; NOTE, this is only properly defined when end is greater than start. -(define-public (datetime-difference end start) +(define (datetime-difference end start) ;; NOTE Makes both start and end datetimes in the current local time. (let ((fixed-time overflow (time- (get-time% end) (get-time% start)))) diff --git a/module/datetime/timespec.scm b/module/datetime/timespec.scm index 9bfcc402..03e8dd10 100644 --- a/module/datetime/timespec.scm +++ b/module/datetime/timespec.scm @@ -4,16 +4,23 @@ ;;; Code: (define-module (datetime timespec) - :export (make-timespec - timespec? timespec-time timespec-sign timespec-type) - :use-module ((hnh util) :select (set define*-public unless)) + :use-module ((hnh util) :select (set unless)) :use-module ((hnh util exceptions) :select (warning)) :use-module (datetime) :use-module (srfi srfi-1) :use-module (srfi srfi-71) :use-module (srfi srfi-9 gnu) :use-module (calp translation) - ) + :export (make-timespec + timespec? + timespec-time + timespec-sign + timespec-type + + timespec-zero + timespec-add + parse-time-spec + )) ;; timespec as defined by the TZ-database @@ -30,10 +37,10 @@ ;; u, g, z - Universal time (type timespec-type)) ; char -(define-public (timespec-zero) +(define (timespec-zero) (make-timespec (time) '+ #\w)) -(define-public (timespec-add . specs) +(define (timespec-add . specs) (unless (apply eqv? (map timespec-type specs)) (warning (_ "Adding timespecs of differing types"))) @@ -70,7 +77,7 @@ specs)) -(define*-public (parse-time-spec +(define* (parse-time-spec string optional: (suffixes '(#\s #\w #\u #\g #\z))) (let ((type string (cond [(string-rindex string (list->char-set suffixes)) diff --git a/module/datetime/zic.scm b/module/datetime/zic.scm index 393b4ba2..66c0ba06 100644 --- a/module/datetime/zic.scm +++ b/module/datetime/zic.scm @@ -25,11 +25,32 @@ :use-module ((vcomponent recurrence internal) :select (byday make-recur-rule bymonthday)) :use-module (calp translation) - ) + :export (read-zoneinfo + + #| note that make-rule isn't exported |# + rule? + rule-name rule-from rule-to rule-in + rule-on rule-at rule-save rule-letters + + #| note that make-zone-entry isn't exported |# + zone-entry? + zone-entry-stdoff zone-entry-rule + zone-entry-format zone-entry-until + + zoneinfo? + + get-zone + get-rule + + rule->dtstart + rule->rrule + + zone-format + )) ;; returns a <zoneinfo> object -(define-public (read-zoneinfo ports-or-filenames) +(define (read-zoneinfo ports-or-filenames) (parsed-zic->zoneinfo (concatenate (map (lambda (port-or-filename) @@ -57,7 +78,6 @@ (letters rule-letters) ; string ) -(export rule? rule-name rule-from rule-to rule-in rule-on rule-at rule-save rule-letters) (define-immutable-record-type <zone-entry> ; EXPORTED (make-zone-entry stdoff rule format until) @@ -67,8 +87,6 @@ (format zone-entry-format) ; string (until zone-entry-until)) ; <datetime> | #f -(export zone-entry? zone-entry-stdoff zone-entry-rule zone-entry-format zone-entry-until) - (define-immutable-record-type <zone> ; INTERNAL (make-zone name entries) @@ -88,19 +106,17 @@ (rules zoneinfo-rules) ; (map symbol (list <rule>)) (zones zoneinfo-zones)) ; (map string (list <zone-entry>)) -(export zoneinfo?) - ;; @example ;; (get-zone zoneinfo "Europe/Stockholm") ;; @end example -(define-public (get-zone zoneinfo name) +(define (get-zone zoneinfo name) (or (hash-ref (zoneinfo-zones zoneinfo) name) (scm-error 'misc-error "get-zone" "No zone ~a" (list name) #f))) ;; @example ;; (get-rule zoneinfo 'EU) ;; @end example -(define-public (get-rule zoneinfo name) +(define (get-rule zoneinfo name) (or (hashq-ref (zoneinfo-rules zoneinfo) name) (scm-error 'misc-error "get-rule" "No rule ~a" (list name) #f))) @@ -310,7 +326,7 @@ ;; The first time this rule was/will be applied -(define-public (rule->dtstart rule) +(define (rule->dtstart rule) ;; NOTE 'minimum and 'maximum represent the begining and end of time. ;; since I don't have a way to represent those ideas I just set a very ;; high and a very low year here. What 'maximum even entails for a start @@ -350,7 +366,7 @@ (datetime time: (timespec-time timespec))) )) -(define-public (rule->rrule rule) +(define (rule->rrule rule) (if (eq? 'only (rule-to rule)) #f (let ((base (make-recur-rule @@ -388,7 +404,7 @@ wday)))))))) ;; special case of format which works with %s and %z -(define-public (zone-format fmt-string arg) +(define (zone-format fmt-string arg) (let ((idx (string-index fmt-string #\%))) (case (string-ref fmt-string (1+ idx)) [(#\s) (string-replace fmt-string arg diff --git a/module/hnh/util.scm b/module/hnh/util.scm index 1fa3eb83..1e79781f 100644 --- a/module/hnh/util.scm +++ b/module/hnh/util.scm @@ -2,20 +2,66 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-71) #:use-module (srfi srfi-88) ; postfix keywords - #:use-module ((ice-9 optargs) #:select (define*-public)) #:use-module ((sxml fold) #:select (fold-values)) #:use-module ((srfi srfi-9 gnu) #:select (set-fields)) - #:re-export (define*-public fold-values) - #:export (for sort* sort*! - set/r! - -> ->> set set-> aif awhen - let-lazy - case* - and=>> label - print-and-return - begin1 - catch* - ) + #:re-export (fold-values) + #:export (aif + awhen + for + begin1 + print-and-return + swap + case* + set/r! + label + sort* sort*! + find-extreme find-min find-max + filter-sorted + != + take-to + string-take-to + string-first + string-last + as-symb + enumerate + unval + flatten + let-lazy + map/dotted + + assq-merge + kvlist->assq + assq-limit + + group-by + split-by + + span-upto + cross-product + + string-flatten + intersperse + insert-ordered + + -> ->> + set set-> + and=>> + + downcase-symbol + group + iterate + valued-map + + assoc-ref-all + assq-ref-all + assv-ref-all + + vector-last + + ->str ->string ->quoted-string + + catch* + ) #:replace (set! define-syntax when unless)) @@ -92,7 +138,7 @@ -(define-public (swap f) +(define (swap f) (lambda args (apply f (reverse args)))) @@ -183,7 +229,7 @@ ;; Returns 2 values. The extremest item in @var{items}, ;; and the other items in some order. ;; Ord b => (list a) [, (b, b -> bool), (a -> b)] -> a, (list a) -(define*-public (find-extreme items optional: (< <) (access identity)) +(define* (find-extreme items optional: (< <) (access identity)) (when (null? items) (scm-error 'wrong-type-arg "find-extreme" "Can't find extreme in an empty list" @@ -199,51 +245,51 @@ ;; seeds: (car items) '())) -(define*-public (find-min list optional: (access identity)) +(define* (find-min list optional: (access identity)) (find-extreme list < access)) -(define*-public (find-max list optional: (access identity)) +(define* (find-max list optional: (access identity)) (find-extreme list > access)) -(define-public (filter-sorted proc list) +(define (filter-sorted proc list) (take-while proc (drop-while (negate proc) list))) ;; (define (!= a b) (not (= a b))) -(define-public != (negate =)) +(define != (negate =)) -(define-public (take-to lst i) +(define (take-to lst i) "Like @var{take}, but might lists shorter than length." (if (> i (length lst)) lst (take lst i))) -(define-public (string-take-to str i) +(define (string-take-to str i) (if (> i (string-length str)) str (string-take str i))) -(define-public (string-first str) +(define (string-first str) (string-ref str 0)) -(define-public (string-last str) +(define (string-last str) (string-ref str (1- (string-length str)))) -(define-public (as-symb s) +(define (as-symb s) (if (string? s) (string->symbol s) s)) -(define-public (enumerate lst) +(define (enumerate lst) (zip (iota (length lst)) lst)) ;; Takes a procedure returning multiple values, and returns a procedure which ;; takes the same arguments as the original procedure, but only returns one of ;; the return values. Which value to return can be sent as an additional parameter. -(define*-public (unval proc #:optional (n 0)) +(define* (unval proc #:optional (n 0)) (lambda args (call-with-values (lambda () (apply proc args)) (lambda args (list-ref args n))))) -(define-public (flatten lst) +(define (flatten lst) (fold (lambda (subl done) (append done ((if (list? subl) flatten list) subl))) '() lst)) @@ -256,7 +302,7 @@ (let-syntax ((field (identifier-syntax (force field))) ...) body ...))])) -(define-public (map/dotted proc dotted-list) +(define (map/dotted proc dotted-list) (cond ((null? dotted-list) '()) ((not-pair? dotted-list) (proc dotted-list)) (else @@ -271,24 +317,24 @@ ;; (assq-merge '((k 1)) '((k 2))) ;; => ((k 2 1)) ;; @end example -(define-public (assq-merge a b) +(define (assq-merge a b) (fold (lambda (entry alist) (let* ((k v (car+cdr entry)) (o (assq-ref alist k))) (assq-set! alist k (append v (or o '()))))) (copy-tree a) b)) -(define-public (kvlist->assq kvlist) +(define (kvlist->assq kvlist) (map (lambda (pair) (cons (keyword->symbol (car pair)) (cdr pair))) (group kvlist 2))) -(define*-public (assq-limit alist optional: (number 1)) +(define* (assq-limit alist optional: (number 1)) (map (lambda (pair) (take-to pair (1+ number))) alist)) -(define-public (group-by proc lst) +(define (group-by proc lst) (let ((h (make-hash-table))) (for value in lst (let ((key (proc value))) @@ -298,7 +344,7 @@ ;; (split-by '(0 1 2 3 4 2 5 6) 2) ;; ⇒ ((0 1) (3 4) (5 6)) -(define-public (split-by list item) +(define (split-by list item) (let loop ((done '()) (current '()) (rem list)) @@ -325,7 +371,7 @@ ;; ⇒ () ;; ⇒ (#\H #\1 #\2 #\3 #\4 #\5 #\6) ;; @end example -(define-public (span-upto count predicate list) +(define (span-upto count predicate list) (let loop ((remaining count) (taken '()) (list list)) @@ -348,7 +394,7 @@ l2)) l1))) -(define-public (cross-product . args) +(define (cross-product . args) (if (null? args) '() (let ((last rest (car+cdr (reverse args)))) @@ -357,12 +403,12 @@ ;; Given an arbitary tree, do a pre-order traversal, appending all strings. ;; non-strings allso allowed, converted to strings and also appended. -(define-public (string-flatten tree) +(define (string-flatten tree) (cond [(string? tree) tree] [(list? tree) (string-concatenate (map string-flatten tree))] [else (format #f "~a" tree)])) -(define-public (intersperse item list) +(define (intersperse item list) (let loop ((flipflop #f) (rem list)) (if (null? rem) @@ -376,7 +422,7 @@ ;; (insert-ordered 5 (iota 10)) ;; ⇒ (0 1 2 3 4 5 5 6 7 8 9) ;; @end example -(define*-public (insert-ordered item collection optional: (< <)) +(define* (insert-ordered item collection optional: (< <)) (cond [(null? collection) (list item)] [(< item (car collection)) @@ -430,7 +476,7 @@ (and=>> (and=> value proc) rest ...)])) -(define-public (downcase-symbol symb) +(define (downcase-symbol symb) (-> symb symbol->string string-downcase @@ -442,7 +488,7 @@ ;; ⇒ ((0 1) (2 3) (4 5) (6 7) (8 9)) ;; @end example ;; Requires that width|(length list) -(define-public (group list width) +(define (group list width) (unless (null? list) (let ((row rest (split-at list width))) (cons row (group rest width))))) @@ -450,14 +496,14 @@ ;; repeatedly apply @var{proc} to @var{base} ;; unitl @var{until} is satisfied. ;; (a → a), (a → bool), a → a -(define-public (iterate proc until base) +(define (iterate proc until base) (let loop ((o base)) (if (until o) o (loop (proc o))))) ;; (a → values a), list ... → values a -(define-public (valued-map proc . lists) +(define (valued-map proc . lists) (apply values (apply append-map (lambda args @@ -474,22 +520,22 @@ ;; (assoc-ref-all '((a . 1) (b . 2) (a . 3)) 'a) ;; ⇒ (1 3) ;; @end -(define-public (assoc-ref-all alist key) (ass%-ref-all alist key equal?)) -(define-public (assq-ref-all alist key) (ass%-ref-all alist key eq?)) -(define-public (assv-ref-all alist key) (ass%-ref-all alist key eqv?)) +(define (assoc-ref-all alist key) (ass%-ref-all alist key equal?)) +(define (assq-ref-all alist key) (ass%-ref-all alist key eq?)) +(define (assv-ref-all alist key) (ass%-ref-all alist key eqv?)) -(define-public (vector-last v) +(define (vector-last v) (vector-ref v (1- (vector-length v)))) -(define-public (->str any) +(define (->str any) (with-output-to-string (lambda () (display any)))) -(define-public ->string ->str) +(define ->string ->str) -(define-public (->quoted-string any) +(define (->quoted-string any) (with-output-to-string (lambda () (write any)))) diff --git a/module/hnh/util/exceptions.scm b/module/hnh/util/exceptions.scm index eed310bb..36b018d1 100644 --- a/module/hnh/util/exceptions.scm +++ b/module/hnh/util/exceptions.scm @@ -6,33 +6,38 @@ #:use-module ((system vm frame) :select (frame-bindings binding-ref)) - ) + :export (warning-handler + warnings-are-errors + warning + fatal + filter-stack + )) -(define-public warning-handler +(define warning-handler (make-parameter (lambda (fmt . args) (format #f "WARNING: ~?~%" fmt args)))) -(define-public warnings-are-errors +(define warnings-are-errors (make-parameter #f)) ;; forwards return from warning-hander. By default returns an unspecified value, ;; but instances are free to provide a proper return value and use it. -(define-public (warning fmt . args) +(define (warning fmt . args) (display (apply (warning-handler) fmt (or args '())) (current-error-port)) (when (warnings-are-errors) (throw 'warning fmt args))) -(define-public (fatal fmt . args) +(define (fatal fmt . args) (display (format #f "FATAL: ~?~%" fmt (or args '())) (current-error-port)) (raise 2) ) -(define-public (filter-stack pred? stk) +(define (filter-stack pred? stk) (concatenate (for i in (iota (stack-length stk)) (filter pred? (map binding-ref (frame-bindings (stack-ref stk i))))))) diff --git a/module/hnh/util/graph.scm b/module/hnh/util/graph.scm index 01e9a63a..9aff7c77 100644 --- a/module/hnh/util/graph.scm +++ b/module/hnh/util/graph.scm @@ -8,7 +8,16 @@ :use-module (hnh util) :use-module (srfi srfi-1) :use-module (srfi srfi-71) - :use-module (srfi srfi-9 gnu)) + :use-module (srfi srfi-9 gnu) + :export (make-graph + rebuild-graph + graph-empty? + add-node + get-node + remove-node + find-node-without-dependencies + find-and-remove-node-without-dependencies + resolve-dependency-graph)) ;; Immutable directed graph (define-immutable-record-type <graph> @@ -20,23 +29,23 @@ (node-equal? node-equal?) ; node, node -> symb ) -(define*-public (make-graph optional: - (node-key-proc identity) - (node-equal? eq?)) +(define* (make-graph optional: + (node-key-proc identity) + (node-equal? eq?)) (make-graph% '() '() node-key-proc node-equal?)) -(define*-public (rebuild-graph optional: old-graph - (nodes '()) (edges '())) +(define* (rebuild-graph optional: old-graph + (nodes '()) (edges '())) (make-graph% nodes edges (if old-graph (node-key-proc old-graph) identity) (if old-graph (node-equal? old-graph) eq?))) -(define-public (graph-empty? graph) +(define (graph-empty? graph) (null? (graph-nodes graph))) ;; Add node to graph. Adds directed edges from node to neighbours ;; graph, node, (list node-key) → graph -(define-public (add-node graph node edge-neighbours) +(define (add-node graph node edge-neighbours) (rebuild-graph graph (lset-adjoin (node-equal? graph) (graph-nodes graph) @@ -46,12 +55,12 @@ edge-neighbours)))) ;; get node by key -(define-public (get-node graph key) +(define (get-node graph key) (find (lambda (node) (eq? key ((node-key-proc graph) node))) (graph-nodes graph))) ;; Remove node by @var{node-equal?} -(define-public (remove-node graph node) +(define (remove-node graph node) (rebuild-graph graph (remove (lambda (other) ((node-equal? graph) node other)) @@ -64,14 +73,14 @@ ;; NOTE this is O(n^2) (maybe, sort of?) ;; Getting it faster would require building an index, which ;; is hard since there isn't a total order on symbols. -(define-public (find-node-without-dependencies graph) +(define (find-node-without-dependencies graph) (find (lambda (node) (let ((key ((node-key-proc graph) node))) (not (find (lambda (edge) (eq? key (car edge))) (graph-edges graph))))) (graph-nodes graph))) ;; graph → node x graph -(define-public (find-and-remove-node-without-dependencies graph) +(define (find-and-remove-node-without-dependencies graph) (let ((node (find-node-without-dependencies graph))) (unless node (scm-error 'graph-error "find-and-remove-node-without-dependencies" @@ -83,7 +92,7 @@ ;; Returns a list of all nodes so that each node is before its dependants. ;; A missing dependency (and probably a loop) is an error, and currently ;; leads to some weird error messages. -(define-public (resolve-dependency-graph graph) +(define (resolve-dependency-graph graph) (catch 'graph-error (lambda () (let loop ((graph graph)) diff --git a/module/hnh/util/io.scm b/module/hnh/util/io.scm index 3a595b67..d638ebb4 100644 --- a/module/hnh/util/io.scm +++ b/module/hnh/util/io.scm @@ -1,19 +1,23 @@ (define-module (hnh util io) :use-module ((hnh util) :select (begin1)) - :use-module ((ice-9 rdelim) :select (read-line))) + :use-module ((ice-9 rdelim) :select (read-line)) + :export (open-input-port + open-output-port + read-lines + with-atomic-output-to-file)) -(define-public (open-input-port str) +(define (open-input-port str) (if (string=? "-" str) (current-input-port) (open-input-file str))) -(define-public (open-output-port str) +(define (open-output-port str) (if (string=? "-" str) (current-output-port) (open-output-file str))) -(define-public (read-lines port) +(define (read-lines port) (let ((line (read-line port))) (if (eof-object? line) '() (cons line (read-lines port))))) @@ -26,7 +30,7 @@ ;; ;; propagates the return value of @var{thunk} upon successfully writing ;; the file, and @code{#f} otherwise. -(define-public (with-atomic-output-to-file filename thunk) +(define (with-atomic-output-to-file filename thunk) ;; copy to enusre writable string (define tmpfile (string-copy (string-append (dirname filename) diff --git a/module/hnh/util/options.scm b/module/hnh/util/options.scm index 57473816..0faebf89 100644 --- a/module/hnh/util/options.scm +++ b/module/hnh/util/options.scm @@ -3,10 +3,13 @@ :use-module (ice-9 match) :use-module (srfi srfi-1) :use-module (text markup) - ) + :export (getopt-opt + format-arg-help + print-arg-help + )) ;; option-assoc → getopt-valid option-assoc -(define-public (getopt-opt options) +(define (getopt-opt options) (define ice-9-names '(single-char required? value predicate)) (for (option-name flags ...) in options (cons option-name @@ -38,8 +41,8 @@ `((blockquote ,@it) (br)))))))) -(define-public (format-arg-help options) +(define (format-arg-help options) (sxml->ansi-text (cons '*TOP* (map sxml->ansi-text (map fmt-help options))))) -(define*-public (print-arg-help options optional: (port (current-error-port))) +(define* (print-arg-help options optional: (port (current-error-port))) (display (format-arg-help options) port)) diff --git a/module/hnh/util/path.scm b/module/hnh/util/path.scm index 340c2d8b..ac6df491 100644 --- a/module/hnh/util/path.scm +++ b/module/hnh/util/path.scm @@ -1,12 +1,18 @@ (define-module (hnh util path) :use-module (srfi srfi-1) :use-module (srfi srfi-71) - :use-module (hnh util)) + :use-module (hnh util) + :export (path-append + path-join + path-split + file-hidden? + filename-extension + realpath)) (define // file-name-separator-string) (define /? file-name-separator?) -(define-public (path-append . strings) +(define (path-append . strings) (fold (lambda (s done) (string-append done @@ -28,7 +34,7 @@ (cdr strings) )) -(define-public (path-join lst) (apply path-append lst)) +(define (path-join lst) (apply path-append lst)) ;; @example ;; (path-split "usr/lib/test") @@ -40,7 +46,7 @@ ;; (path-split "//usr////lib/test") ;; ⇒ ("" "usr" "lib" "test") ;; @end example -(define-public (path-split path) +(define (path-split path) (let ((head tail (car+cdr (reverse @@ -54,16 +60,15 @@ (cons head (remove string-null? tail)))) -(define-public (file-hidden? path) +(define (file-hidden? path) (define base (basename path)) (and (not (string-null? base)) (char=? #\. (string-ref base 0)))) -(define-public (filename-extension filename) +(define (filename-extension filename) (car (reverse (string-split filename #\.)))) - -(define-public (realpath filename) +(define (realpath filename) (unless (string? filename) (scm-error 'wrong-type-arg "realpath" "filename not a string: ~a" diff --git a/module/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm index 14e5b672..bc7a480d 100644 --- a/module/srfi/srfi-41/util.scm +++ b/module/srfi/srfi-41/util.scm @@ -4,8 +4,20 @@ #:use-module (srfi srfi-71) #:use-module ((ice-9 sandbox) :select (call-with-time-limit)) #:use-module (hnh util) ; find-min - #:export (stream-car+cdr interleave-streams - stream-timeslice-limit)) + #:export (stream-car+cdr + interleave-streams + stream-insert + filter-sorted-stream + filter-sorted-stream* + get-stream-interval + stream-find + stream-remove + stream->values + repeating-naturals + stream-partition + stream-split + stream-paginate + stream-timeslice-limit)) (define (stream-car+cdr stream) (values (stream-car stream) @@ -24,7 +36,7 @@ (m ms (stream-car+cdr min))) (stream-cons m (interleave-streams < (cons ms other))))))) -(define-public (stream-insert < item s) +(define (stream-insert < item s) (interleave-streams < (list (stream item) s))) ;; Requires that stream is a total order in regards to what we filter @@ -35,7 +47,7 @@ ;; The collection is sorted on start time, and we want all events overlapping the ;; interval 2020-02-01 to 2020-02-29. We would get the long event, but then probably ;; stop because all regular small events in january. -(define-public (filter-sorted-stream pred stream) +(define (filter-sorted-stream pred stream) (stream-take-while pred (stream-drop-while (negate pred) stream))) @@ -44,7 +56,7 @@ ;; Simmilar to the regular @code{filter-sorted-stream}, but once an ;; element satisfies @code{keep-remaning?} then the remaining tail ;; of the stream is all assumed to be good. -(define-public (filter-sorted-stream* pred? keep-remaining? stream) +(define (filter-sorted-stream* pred? keep-remaining? stream) (cond [(stream-null? stream) stream-null] [(keep-remaining? (stream-car stream)) stream] [(pred? (stream-car stream)) @@ -58,7 +70,7 @@ ;; returns all object in stream from the first object satisfying ;; start-pred, until the last object which sattisfies end-pred. -(define-public (get-stream-interval start-pred end-pred stream) +(define (get-stream-interval start-pred end-pred stream) (stream-take-while end-pred (stream-drop-while (negate start-pred) @@ -67,20 +79,20 @@ ;; Finds the first element in stream satisfying pred. ;; Returns #f if nothing was found -(define-public (stream-find pred stream) +(define (stream-find pred stream) (cond ((stream-null? stream) #f) ((pred (stream-car stream)) (stream-car stream)) (else (stream-find pred (stream-cdr stream))))) -(define-public (stream-remove pred stream) +(define (stream-remove pred stream) (stream-filter (negate pred) stream)) -(define-public (stream->values stream) +(define (stream->values stream) (apply values (stream->list stream))) ;; Natural numbers from 1 and up, each number repeated 7 times. -(define-public (repeating-naturals from repeats) +(define (repeating-naturals from repeats) (stream-unfold cdr ; map (const #t) ; continue? @@ -94,14 +106,14 @@ ;; which satisfiy @var{pred}, and a stream of those elements ;; that don't. @var{pred} is called once per value in the ;; input stream. -(define-public (stream-partition pred stream) +(define (stream-partition pred stream) (let ((strm (stream-zip (stream-map pred stream) stream))) (values (stream-map cadr (stream-filter car strm)) (stream-map cadr (stream-remove car strm))))) -(define-public (stream-split idx stream) +(define (stream-split idx stream) (stream-cons (stream-take idx stream) (stream-drop idx stream))) @@ -114,7 +126,7 @@ page (stream-paginate rest page-size)))))) -(define*-public (stream-paginate stream optional: (page-size 10)) +(define* (stream-paginate stream optional: (page-size 10)) (stream-paginate% stream page-size)) diff --git a/module/sxml/namespace.scm b/module/sxml/namespace.scm index af770f7a..144d1905 100644 --- a/module/sxml/namespace.scm +++ b/module/sxml/namespace.scm @@ -1,6 +1,7 @@ (define-module (sxml namespace) :use-module (hnh util) - :use-module (sxml transform)) + :use-module (sxml transform) + :export (move-to-namespace)) (define* (symbol-split symbol key: (sep #\:)) (->> (-> symbol @@ -29,7 +30,7 @@ ;; => (c:a (c:b)) ;; @end example ;; sxml, (U symbol string #f (alist (U #f symbol) (U symbol string #f))) → sxml -(define-public (move-to-namespace sxml namespace-map) +(define (move-to-namespace sxml namespace-map) (define (nssymb key) (define namespace diff --git a/module/sxml/transformations.scm b/module/sxml/transformations.scm index 0978d71c..61de42aa 100644 --- a/module/sxml/transformations.scm +++ b/module/sxml/transformations.scm @@ -9,10 +9,13 @@ :use-module (hnh util) :use-module ((srfi srfi-1) :select (concatenate)) :use-module ((sxml transform) :select (pre-post-order)) - ) + :export (attribute-transformer + href-transformer + href-prefixer + )) ;; sxml, bindings → sxml -(define-public (attribute-transformer +(define (attribute-transformer tree attribute-bindings) (define bindings @@ -24,13 +27,13 @@ (pre-post-order tree bindings)) -(define-public (href-transformer tree transformer) +(define (href-transformer tree transformer) (attribute-transformer tree `((href . ,(lambda (_ . content) `(href ,@(transformer (string-concatenate (map ->str content)))) ))))) -(define-public (href-prefixer tree prefix) +(define (href-prefixer tree prefix) (href-transformer tree (lambda (str) (string-append prefix str)))) diff --git a/module/text/flow.scm b/module/text/flow.scm index 3b958480..315bea06 100644 --- a/module/text/flow.scm +++ b/module/text/flow.scm @@ -8,11 +8,11 @@ :use-module (text util) :use-module (srfi srfi-1) :use-module (srfi srfi-71) - ) + :export (flow-text)) ;; str -> (str) -(define*-public (flow-text str #:key (width 70)) +(define* (flow-text str #:key (width 70)) (flatten (map (lambda (line) (justify-line line #:width width)) (lines str)))) diff --git a/module/text/markup.scm b/module/text/markup.scm index 53dab321..a7a905df 100644 --- a/module/text/markup.scm +++ b/module/text/markup.scm @@ -6,11 +6,12 @@ :use-module (ice-9 pretty-print) :use-module (text util) :use-module (text flow) - :use-module (texinfo string-utils)) + :use-module (texinfo string-utils) + :export (sxml->ansi-text)) ;; Takes an HTML-like sxml coded tree, and produces a string with ;; appropriate spacing and ANSI-escapes for different tags. -(define-public (sxml->ansi-text tree) +(define (sxml->ansi-text tree) ((parse-tree ontree onleaf) tree)) diff --git a/module/text/numbers/en.scm b/module/text/numbers/en.scm index 622decd5..6a5a636d 100644 --- a/module/text/numbers/en.scm +++ b/module/text/numbers/en.scm @@ -1,14 +1,17 @@ (define-module (text numbers en) - :use-module (ice-9 format)) + :use-module (ice-9 format) + :export (number->string-cardinal + number->string-ordinal + each-string)) -(define-public (number->string-cardinal n) +(define (number->string-cardinal n) (format #f "~r" n)) -(define-public (number->string-ordinal n) +(define (number->string-ordinal n) (format #f "~:r" n)) ;; Allows extra args to handle eventual local changes. -(define-public (each-string count . _) +(define (each-string count . _) (case count [(1) "each"] [(2) "every other"] diff --git a/module/text/numbers/sv.scm b/module/text/numbers/sv.scm index b70412fb..1760f622 100644 --- a/module/text/numbers/sv.scm +++ b/module/text/numbers/sv.scm @@ -1,6 +1,9 @@ (define-module (text numbers sv) :use-module (srfi srfi-71) - :use-module (hnh util)) + :use-module (hnh util) + :export (number->string-cardinal + number->string-ordinal + each-string)) ;; only used in number->string-cardinal (define (large-prefix e) @@ -17,7 +20,7 @@ [(<= 60 e 65) "dec"] )) -(define-public (number->string-cardinal n) +(define (number->string-cardinal n) (cond [(< n 0) (string-append "minus " (number->string-cardinal (- n)))] [(= n 0) "noll"] [(= n 1) "ett"] @@ -89,7 +92,7 @@ (string-append "det stora talet " (number->string n))])) -(define*-public (number->string-ordinal +(define* (number->string-ordinal n key: a-form?) (define a-string (if a-form? "a" "e")) (cond [(>= -3 n) (format #f "~a sista" (number->string-ordinal (- n)))] @@ -146,7 +149,7 @@ ;; (each-string 2) ; => "varannan" ;; (each-string 3) ; => "var tredje" ;; (each-string 3 #t) ; => "vart tredje" -(define*-public (each-string count optional: neutrum) +(define* (each-string count optional: neutrum) (string-flatten (cons "var" diff --git a/module/text/util.scm b/module/text/util.scm index 7144b032..5ade7144 100644 --- a/module/text/util.scm +++ b/module/text/util.scm @@ -3,18 +3,22 @@ ;;; Code: (define-module (text util) - :use-module ((hnh util) :select (define*-public intersperse) ) - ) + :use-module ((hnh util) :select (intersperse)) + :export (words unwords lines unlines + true-string-length + true-string-pad + trim-to-width + add-enumeration-punctuation)) -(define-public (words str) (string-split str #\space)) -(define-public (unwords list) (string-join list " " 'infix)) +(define (words str) (string-split str #\space)) +(define (unwords list) (string-join list " " 'infix)) -(define-public (lines str) (string-split str #\newline)) -(define-public (unlines list) (string-join list "\n" 'infix)) +(define (lines str) (string-split str #\newline)) +(define (unlines list) (string-join list "\n" 'infix)) ;; Alternative string-length whith counts ANSI escapes as 0-length. ;; NOTE Some way to opt in and out of different features would be nice. -(define-public (true-string-length word) +(define (true-string-length word) (let loop ((chars (string->list word))) (if (null? chars) 0 @@ -23,7 +27,7 @@ (loop (cdr (memv #\m chars))) (1+ (loop (cdr chars)))))))) -(define*-public (true-string-pad str len optional: (chr #\space)) +(define* (true-string-pad str len optional: (chr #\space)) (let ((strlen (true-string-length str))) (if (> strlen len) str @@ -31,7 +35,7 @@ str)))) -(define-public (trim-to-width str len) +(define (trim-to-width str len) (let ((trimmed (string-pad-right str len))) (if (< (string-length trimmed) (string-length str)) @@ -40,7 +44,7 @@ trimmed))) ;; TODO more options for infix strings -(define*-public (add-enumeration-punctuation +(define* (add-enumeration-punctuation list optional: (final-delim "&")) (cond [(null? list) ""] [(= 1 (length list)) (car list)] diff --git a/module/vcomponent/base.scm b/module/vcomponent/base.scm index 3d40ef9c..e79a4d5c 100644 --- a/module/vcomponent/base.scm +++ b/module/vcomponent/base.scm @@ -5,7 +5,34 @@ :use-module (srfi srfi-9 gnu) :use-module (srfi srfi-17) :use-module (ice-9 hash-table) - :use-module ((ice-9 optargs) :select (define*-public)) + :export (make-vline + vline? + vline-key + vline-source + + make-vcomponent + vcomponent? + children type parent + + add-child! remove-child! + + delete-property! + prop* prop + extract extract* + + delete-parameter! + value + param + + parameters + properties + + copy-vcomponent + x-property? + internal-field? + + + ) ) @@ -31,8 +58,6 @@ (source get-source set-source!) ) -(export vline? vline-key) - (set-record-type-printer! <vline> (lambda (v p) @@ -41,11 +66,11 @@ (get-vline-value v) (hash-map->list list (get-vline-parameters v))))) -(define-public vline-source +(define vline-source (make-procedure-with-setter get-source set-source!)) -(define*-public (make-vline key value #:optional (ht (make-hash-table))) +(define* (make-vline key value #:optional (ht (make-hash-table))) (make-vline% key value ht)) (define-record-type <vcomponent> @@ -55,7 +80,6 @@ (children children set-component-children!) (parent get-component-parent set-component-parent!) (properties get-component-properties)) -(export vcomponent? children type) ((@ (srfi srfi-9 gnu) set-record-type-printer!) <vcomponent> @@ -66,18 +90,18 @@ (and=> (get-component-parent c) type)))) ;; TODO should this also update the parent -(define-public parent +(define parent (make-procedure-with-setter get-component-parent set-component-parent!)) -(define*-public (make-vcomponent #:optional (type 'VIRTUAL)) +(define* (make-vcomponent #:optional (type 'VIRTUAL)) (make-vcomponent% type '() #f (make-hash-table))) -(define-public (add-child! parent child) +(define (add-child! parent child) (set-component-children! parent (cons child (children parent))) (set-component-parent! child parent)) -(define-public (remove-child! parent-component child) +(define (remove-child! parent-component child) (unless (eq? parent-component (parent child)) (scm-error 'wrong-type-arg "remove-child!" "Child doesn't belong to parent" @@ -97,7 +121,7 @@ ;; vline → value -(define-public value +(define value (make-procedure-with-setter get-vline-value set-vline-value!)) @@ -110,12 +134,12 @@ (hashq-set! (get-component-properties component) (as-symb key) value)) -(define-public prop* +(define prop* (make-procedure-with-setter get-prop* set-prop*!)) -(define-public (delete-property! component key) +(define (delete-property! component key) (hashq-remove! (get-component-properties component) (as-symb key))) @@ -131,13 +155,13 @@ (define (set-prop! component key value) (set-property! component (as-symb key) value)) -(define-public prop +(define prop (make-procedure-with-setter get-prop set-prop!)) -(define-public param +(define param (make-procedure-with-setter (lambda (vline parameter-key) ;; TODO `list' is a hack since a bit to much code depends @@ -150,17 +174,17 @@ (as-symb parameter-key) val)))) -(define-public (delete-parameter! vline parameter-key) +(define (delete-parameter! vline parameter-key) (hashq-remove! (get-vline-parameters vline) (as-symb parameter-key))) ;; Returns the parameters of a property as an assoc list. ;; @code{(map car <>)} leads to available parameters. -(define-public (parameters vline) +(define (parameters vline) (hash-map->list list (get-vline-parameters vline))) -(define-public (properties component) +(define (properties component) (hash-map->list cons (get-component-properties component))) (define (copy-vline vline) @@ -169,7 +193,7 @@ ;; TODO deep-copy on parameters? (get-vline-parameters vline))) -(define-public (copy-vcomponent component) +(define (copy-vcomponent component) (make-vcomponent% (type component) ;; TODO deep copy? @@ -183,16 +207,16 @@ (copy-vline value)))) (get-component-properties component))))) -(define-public (extract field) +(define (extract field) (lambda (e) (prop e field))) -(define-public (extract* field) +(define (extract* field) (lambda (e) (prop* e field))) -(define-public (x-property? symb) +(define (x-property? symb) (string=? "X-" (string-take (symbol->string symb) 2))) -(define*-public (internal-field? symbol optional: (prefix "-")) +(define* (internal-field? symbol optional: (prefix "-")) (string=? prefix (string-take-to (symbol->string symbol) (string-length prefix)))) diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index bb4fe50e..5fb1148c 100644 --- a/module/vcomponent/datetime.scm +++ b/module/vcomponent/datetime.scm @@ -12,8 +12,20 @@ event-overlaps? overlapping? event-contains? - ev-time<?) - ) + event-zero-length? + ev-time<? + + event-length + event-length/clamped + event-length/day + + long-event? + really-long-event? + + events-between + + zoneinfo->vtimezone + )) ;;; date time pointer #; @@ -50,16 +62,16 @@ Event must have the DTSTART and DTEND protperty set." (end (add-day start))) (event-overlaps? ev start end))) -(define-public (event-zero-length? ev) +(define (event-zero-length? ev) (and (datetime? (prop ev 'DTSTART)) (not (prop ev 'DTEND)))) -(define-public (ev-time<? a b) +(define (ev-time<? a b) (date/-time<? (prop a 'DTSTART) (prop b 'DTSTART))) ;; Returns length of the event @var{e}, as a time-duration object. -(define-public (event-length e) +(define (event-length e) (if (not (prop e 'DTEND)) (if (date? (prop e 'DTSTART)) (date day: 1) @@ -75,7 +87,7 @@ Event must have the DTSTART and DTEND protperty set." ;; |X| part of event within that time (X) ;; ;; Returns the length of the interval (X). -(define-public (event-length/clamped start-date end-date e) +(define (event-length/clamped start-date end-date e) (let ((end (or (prop e 'DTEND) (if (date? (prop e 'DTSTART)) (date+ (prop e 'DTSTART) (date day: 1)) @@ -94,7 +106,7 @@ Event must have the DTSTART and DTEND protperty set." ;; starting at the time @var{start-of-day}. ;; currently the secund argument is a date, but should possibly be changed ;; to a datetime to allow for more explicit TZ handling? -(define-public (event-length/day date e) +(define (event-length/day date e) (if (not (prop e 'DTEND)) (if (date? (prop e 'DTSTART)) (time hour: 24) @@ -121,7 +133,7 @@ Event must have the DTSTART and DTEND protperty set." ;; or if the total length of the event is greater than 24h. ;; For practical purposes, an event being long means that it shouldn't be rendered as a part ;; of a regular day. -(define-public (long-event? ev) +(define (long-event? ev) (if (date? (prop ev 'DTSTART)) #t (aif (prop ev 'DTEND) @@ -129,7 +141,7 @@ Event must have the DTSTART and DTEND protperty set." (datetime-difference it (prop ev 'DTSTART))) #f))) -(define-public (really-long-event? ev) +(define (really-long-event? ev) (let ((start (prop ev 'DTSTART)) (end (prop ev 'DTEND))) (if (date? start) @@ -153,7 +165,7 @@ Event must have the DTSTART and DTEND protperty set." #f)))) ;; date, date, [sorted-stream events] → [sorted-stream events] -(define-public (events-between start-date end-date events) +(define (events-between start-date end-date events) (define (overlaps e) (timespan-overlaps? start-date (date+ end-date (date day: 1)) (prop e 'DTSTART) (or (prop e 'DTEND) @@ -212,7 +224,7 @@ Event must have the DTSTART and DTEND protperty set." (<= (rule-from rule) start-y (rule-to rule))]))) ;; event is for limiter -(define-public (zoneinfo->vtimezone zoneinfo zone-name event) +(define (zoneinfo->vtimezone zoneinfo zone-name event) (define vtimezone (make-vcomponent 'VTIMEZONE)) (define last-until (datetime date: (date month: 1 day: 1))) (define last-offset (timespec-zero)) diff --git a/module/vcomponent/datetime/output.scm b/module/vcomponent/datetime/output.scm index b75fd564..614438da 100644 --- a/module/vcomponent/datetime/output.scm +++ b/module/vcomponent/datetime/output.scm @@ -5,11 +5,15 @@ :use-module (text util) :use-module (calp translation) :use-module ((hnh util exceptions) :select (warning)) - ) + :export (format-recurrence-rule + format-summary + format-description + fmt-time-span + )) ;; ev → sxml ;; TODO translation -(define-public (format-recurrence-rule ev) +(define (format-recurrence-rule ev) ;; [FRR] ;; Part of the sentance "Repeated [every two weeks], except on ~a, ~a & ~a" ;; See everything tagged [FRR] @@ -37,11 +41,11 @@ (map value it))))) ".")) -(define-public (format-summary ev str) +(define (format-summary ev str) ((@ (calp html filter) summary-filter) ev str)) ;; NOTE this should have information about context (html/term/...) -(define-public (format-description ev str) +(define (format-description ev str) (catch #t (lambda () ((@ (calp html filter) description-filter) ev str)) (lambda (err . args) @@ -53,7 +57,7 @@ ;; Takes an event, and returns a pretty string for the time interval ;; the event occupies. -(define-public (fmt-time-span ev) +(define (fmt-time-span ev) (cond [(prop ev 'DTSTART) date? => (lambda (s) (cond [(prop ev 'DTEND) diff --git a/module/vcomponent/duration.scm b/module/vcomponent/duration.scm index 637d7db4..449645fc 100644 --- a/module/vcomponent/duration.scm +++ b/module/vcomponent/duration.scm @@ -6,7 +6,10 @@ :use-module (ice-9 match) :use-module (srfi srfi-9 gnu) :use-module (srfi srfi-1) - :export (duration parse-duration)) + :export (duration + parse-duration + format-duration + )) (define-immutable-record-type <duration> (make-duration sign week day dur-time) @@ -26,7 +29,7 @@ (make-duration sign week day time)) -(define-public (format-duration duration) +(define (format-duration duration) (with-output-to-string (lambda () (unless (eq? '+ (duration-sign duration)) diff --git a/module/vcomponent/formats/common/types.scm b/module/vcomponent/formats/common/types.scm index 1a7ec0da..a8a923da 100644 --- a/module/vcomponent/formats/common/types.scm +++ b/module/vcomponent/formats/common/types.scm @@ -7,7 +7,7 @@ :use-module (srfi srfi-71) :use-module (datetime timespec) :use-module (calp translation) - ) + :export (get-parser)) ;; BINARY (define (parse-binary props value) @@ -136,7 +136,7 @@ (hashq-set! type-parsers 'URI parse-uri) (hashq-set! type-parsers 'UTC-OFFSET parse-utc-offset) -(define-public (get-parser type) +(define (get-parser type) (or (hashq-ref type-parsers type #f) (scm-error 'misc-error "get-parser" (_ "No parser for type ~a") (list type) #f))) diff --git a/module/vcomponent/formats/ical/output.scm b/module/vcomponent/formats/ical/output.scm index 489cdc00..fbb9c862 100644 --- a/module/vcomponent/formats/ical/output.scm +++ b/module/vcomponent/formats/ical/output.scm @@ -17,7 +17,11 @@ :use-module (vcomponent recurrence) :use-module (calp translation) :autoload (vcomponent util instance) (global-event-object) - ) + :export (component->ical-string + print-components-with-fake-parent + print-all-events + print-events-in-interval + )) (define (prodid) (format #f "-//hugo//calp ~a//EN" @@ -140,7 +144,7 @@ (parameters vline))) ":" (value-format key vline)))) -(define-public (component->ical-string component) +(define (component->ical-string component) (format #t "BEGIN:~a\r\n" (type component)) (for-each ;; Special cases depending on key. @@ -192,7 +196,7 @@ CALSCALE:GREGORIAN\r '("dummy" "local"))) -(define-public (print-components-with-fake-parent events) +(define (print-components-with-fake-parent events) ;; The events are probably sorted before, but until I can guarantee ;; that we sort them again here. We need them sorted from earliest @@ -216,7 +220,7 @@ CALSCALE:GREGORIAN\r (print-footer)) -(define-public (print-all-events) +(define (print-all-events) (print-components-with-fake-parent (append (get-fixed-events global-event-object) ;; TODO RECCURENCE-ID exceptions @@ -225,7 +229,7 @@ CALSCALE:GREGORIAN\r ;; the given date range. (get-repeating-events global-event-object)))) -(define-public (print-events-in-interval start end) +(define (print-events-in-interval start end) (print-components-with-fake-parent (append (fixed-events-in-range start end) ;; TODO RECCURENCE-ID exceptions diff --git a/module/vcomponent/formats/ical/parse.scm b/module/vcomponent/formats/ical/parse.scm index cca306c5..49f8f101 100644 --- a/module/vcomponent/formats/ical/parse.scm +++ b/module/vcomponent/formats/ical/parse.scm @@ -12,7 +12,7 @@ :use-module (vcomponent geo) :use-module (vcomponent formats common types) :use-module (calp translation) - ) + :export (parse-calendar)) (define string->symbol (let ((ht (make-hash-table 1000))) @@ -23,7 +23,7 @@ symb))))) ;; TODO rename to parse-vcomponent, or parse-ical (?). -(define-public (parse-calendar port) +(define (parse-calendar port) (parse (map tokenize (read-file port)))) (define-immutable-record-type <line> diff --git a/module/vcomponent/formats/ical/types.scm b/module/vcomponent/formats/ical/types.scm index 67f9f633..7b6aad2e 100644 --- a/module/vcomponent/formats/ical/types.scm +++ b/module/vcomponent/formats/ical/types.scm @@ -6,7 +6,7 @@ :use-module (datetime) :use-module (datetime timespec) :use-module (calp translation) - ) + :export (escape-chars get-writer)) ;; TODO shouldn't these really take vline:s? @@ -45,7 +45,7 @@ ((@ (vcomponent recurrence internal) recur-rule->rrule-string) value)) -(define-public (escape-chars str) +(define (escape-chars str) (define (escape char) (string #\\ char)) (string-concatenate @@ -92,6 +92,6 @@ (hashq-set! type-writers 'URI write-uri) (hashq-set! type-writers 'UTC-OFFSET write-utc-offset) -(define-public (get-writer type) +(define (get-writer type) (or (hashq-ref type-writers type #f) (error (_ "No writer for type") type))) diff --git a/module/vcomponent/formats/vdir/parse.scm b/module/vcomponent/formats/vdir/parse.scm index b21a5f2b..46626402 100644 --- a/module/vcomponent/formats/vdir/parse.scm +++ b/module/vcomponent/formats/vdir/parse.scm @@ -18,7 +18,8 @@ :use-module (calp translation) :use-module (vcomponent formats ical parse) - ) + + :export (parse-vdir)) @@ -26,7 +27,7 @@ ;; All VTIMEZONE's seem to be in "local" time in relation to ;; themselves. Therefore, a simple comparison should work, ;; and then the TZOFFSETTO properties can be subtd. -(define-public (parse-vdir path) +(define (parse-vdir path) ;; TODO empty files here cause "#<eof>" to appear in the output XML, which is *really* bad. (let ((color (catch 'system-error diff --git a/module/vcomponent/formats/vdir/save-delete.scm b/module/vcomponent/formats/vdir/save-delete.scm index fb84d59c..ac520463 100644 --- a/module/vcomponent/formats/vdir/save-delete.scm +++ b/module/vcomponent/formats/vdir/save-delete.scm @@ -17,10 +17,11 @@ :use-module (vcomponent) :use-module (calp translation) :use-module ((hnh util io) :select (with-atomic-output-to-file)) + :export (save-event remove-event) ) -(define-public (save-event event) +(define (save-event event) (define calendar (parent event)) (unless calendar @@ -50,7 +51,7 @@ uid)) -(define-public (remove-event event) +(define (remove-event event) (define calendar (parent event)) (unless (eq? 'vdir (prop calendar '-X-HNH-SOURCETYPE)) (scm-error 'wrong-type-arg "remove-event" diff --git a/module/vcomponent/formats/xcal/output.scm b/module/vcomponent/formats/xcal/output.scm index 26018d92..87ebd32b 100644 --- a/module/vcomponent/formats/xcal/output.scm +++ b/module/vcomponent/formats/xcal/output.scm @@ -8,7 +8,7 @@ :use-module (datetime) :use-module (srfi srfi-1) :use-module (calp translation) - ) + :export (vcomponent->sxcal ns-wrap)) (define (vline->value-tag vline) @@ -94,7 +94,7 @@ (unless (null? outparams) `(parameters ,@outparams))) -(define-public (vcomponent->sxcal component) +(define (vcomponent->sxcal component) (define tagsymb (downcase-symbol (type component))) @@ -129,6 +129,6 @@ ,(unless (null? (children component)) `(components ,@(map vcomponent->sxcal (children component))))))) -(define-public (ns-wrap sxml) +(define (ns-wrap sxml) `(icalendar (@ (xmlns "urn:ietf:params:xml:ns:icalendar-2.0")) ,sxml)) diff --git a/module/vcomponent/formats/xcal/parse.scm b/module/vcomponent/formats/xcal/parse.scm index d9020858..8537956a 100644 --- a/module/vcomponent/formats/xcal/parse.scm +++ b/module/vcomponent/formats/xcal/parse.scm @@ -10,6 +10,7 @@ :use-module (datetime) :use-module (srfi srfi-1) :use-module (calp translation) + :export (sxcal->vcomponent) ) ;; symbol, ht, (list a) -> non-list @@ -179,7 +180,7 @@ ;; are possibilities, which other parts of the code will crash on. ;; TODO ;; since we are feeding user input into this it really should be fixed. -(define-public (sxcal->vcomponent sxcal) +(define (sxcal->vcomponent sxcal) (define type (symbol-upcase (car sxcal))) (define component (make-vcomponent type)) diff --git a/module/vcomponent/formats/xcal/types.scm b/module/vcomponent/formats/xcal/types.scm index 8f13d3d1..a88b6b04 100644 --- a/module/vcomponent/formats/xcal/types.scm +++ b/module/vcomponent/formats/xcal/types.scm @@ -3,7 +3,7 @@ :use-module (vcomponent formats ical types) :use-module (datetime) :use-module (calp translation) - ) + :export (get-writer)) (define (write-boolean _ v) `(boolean ,(if v "true" "false"))) @@ -50,6 +50,6 @@ (hashq-set! sxml-writers 'RECUR write-recur) (hashq-set! sxml-writers 'TEXT write-text) -(define-public (get-writer type) +(define (get-writer type) (or (hashq-ref sxml-writers type #f) (error (_ "No writer for type") type))) diff --git a/module/vcomponent/geo.scm b/module/vcomponent/geo.scm index 27b2cbae..9261076f 100644 --- a/module/vcomponent/geo.scm +++ b/module/vcomponent/geo.scm @@ -1,11 +1,10 @@ (define-module (vcomponent geo) :use-module (hnh util) - :use-module (srfi srfi-9 gnu)) + :use-module (srfi srfi-9 gnu) + :export (make-geo geo-pos? geo-latitude geo-longitude)) (define-immutable-record-type <geographical-position> (make-geo latitude longitude) geo-pos? (latitude geo-latitude) (longitude geo-longitude)) - -(export make-geo geo-pos? geo-latitude geo-longitude) diff --git a/module/vcomponent/recurrence.scm b/module/vcomponent/recurrence.scm index 12f901d2..29cbbc64 100644 --- a/module/vcomponent/recurrence.scm +++ b/module/vcomponent/recurrence.scm @@ -4,4 +4,4 @@ #:use-module (vcomponent recurrence internal) #:re-export (generate-recurrence-set parse-recurrence-rule - repeating? format-recur-rule make-recur-rule)) + repeating? make-recur-rule)) diff --git a/module/vcomponent/recurrence/display/en.scm b/module/vcomponent/recurrence/display/en.scm index 68d435af..c711a75c 100644 --- a/module/vcomponent/recurrence/display/en.scm +++ b/module/vcomponent/recurrence/display/en.scm @@ -6,7 +6,8 @@ :use-module (vcomponent recurrence display common) :use-module ((datetime) :select (time time->string datetime->string - week-day-name))) + week-day-name)) + :export (format-recurrence-rule)) @@ -41,7 +42,7 @@ (map number->string-ordinal lst)))) -(define-public (format-recurrence-rule rrule) +(define (format-recurrence-rule rrule) (string-trim (string-flatten (list diff --git a/module/vcomponent/recurrence/display/sv.scm b/module/vcomponent/recurrence/display/sv.scm index 35b3569b..2bd70657 100644 --- a/module/vcomponent/recurrence/display/sv.scm +++ b/module/vcomponent/recurrence/display/sv.scm @@ -13,7 +13,8 @@ :use-module (vcomponent recurrence display common) :use-module ((datetime) :select (time time->string datetime->string - week-day-name))) + week-day-name)) + :export (format-recurrence-rule)) ;; TODO this currently only groups on offsets, but not on days. ;; So 1MO, 1TU becomes "första måndagen och tisdagen", which is good @@ -49,7 +50,7 @@ (map number->string-ordinal lst) final-delim))) -(define-public (format-recurrence-rule rrule) +(define (format-recurrence-rule rrule) (string-trim (string-flatten (list diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index 83ef4274..07305647 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -10,15 +10,16 @@ :use-module (vcomponent recurrence parse) :use-module (datetime) - :use-module (ice-9 curried-definitions) ) - + :use-module (ice-9 curried-definitions) + :export (rrule-instances + final-event-occurence + generate-recurrence-set)) - ;; Returns #t if any of the predicates return true when applied to object. (define (any-predicate object predicates) ((@ (srfi srfi-1) any) @@ -354,10 +355,8 @@ (stream-remove (lambda (dt) (member dt exdates)) items) items)))) -(export rrule-instances) - -(define-public (final-event-occurence event) +(define (final-event-occurence event) (define rrule (prop event 'RRULE)) (if (or (count rrule) (until rrule)) @@ -390,7 +389,7 @@ ;; <vevent> -> (stream <vevent>) ;; TODO memoize this? -(define-public (generate-recurrence-set base-event) +(define (generate-recurrence-set base-event) (define duration (event-duration base-event)) diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm index 2e04dd64..9cb6b115 100644 --- a/module/vcomponent/recurrence/internal.scm +++ b/module/vcomponent/recurrence/internal.scm @@ -1,6 +1,4 @@ (define-module (vcomponent recurrence internal) - #:export (repeating? format-recur-rule make-recur-rule) - #:use-module (srfi srfi-1) #:use-module (srfi srfi-71) #:use-module (srfi srfi-88) ; better keywords @@ -11,7 +9,27 @@ #:use-module (ice-9 format) #:use-module (hnh util) #:use-module (datetime) - ) + + :replace (count) + :export (repeating? + + make-recur-rule + freq until interval bysecond byminute byhour + byday bymonthday byyearday byweekno bymonth bysetpos + wkst + + recur-rule->rrule-string + recur-rule->rrule-sxml + + weekdays + intervals + )) + +(define weekdays + (weekday-list sun)) + +(define intervals + '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY)) ;; EXDATE is also a property linked to recurense rules @@ -47,19 +65,16 @@ (wkst wkst) ; weekday ) -(export freq until interval bysecond byminute byhour - byday bymonthday byyearday byweekno bymonth bysetpos - wkst) -(export! count) + ;; Interval and wkst have default values, since those are assumed ;; anyways, and having them set frees us from having to check them at ;; the use site. -(define*-public (make-recur-rule - key: - freq until count (interval 1) bysecond byminute byhour - byday bymonthday byyearday byweekno bymonth bysetpos - (wkst monday)) +(define* (make-recur-rule + key: + freq until count (interval 1) bysecond byminute byhour + byday bymonthday byyearday byweekno bymonth bysetpos + (wkst monday)) ;; TODO possibly validate fields here ;; to prevent creation of invalid rules. ;; This was made apparent when wkst was (incorrectly) set to MO, @@ -117,7 +132,7 @@ #f (proc field (get field)))) (record-type-fields <recur-rule>))) -(define-public (recur-rule->rrule-string rrule) +(define (recur-rule->rrule-string rrule) (string-join (map-fields (lambda (field value) @@ -127,7 +142,7 @@ rrule) ";")) -(define-public (recur-rule->rrule-sxml rrule) +(define (recur-rule->rrule-sxml rrule) (map-fields (lambda (field value) (cond [(string-ci=? "UNTIL" (symbol->string field)) @@ -152,12 +167,3 @@ `(,(downcase-symbol field) ,(field->string field value))])) rrule)) - - - - -(define-public weekdays - (weekday-list sun)) - -(define-public intervals - '(SECONDLY MINUTELY HOURLY DAILY WEEKLY MONTHLY YEARLY)) diff --git a/module/vcomponent/recurrence/parse.scm b/module/vcomponent/recurrence/parse.scm index a64cf4a7..91209dc7 100644 --- a/module/vcomponent/recurrence/parse.scm +++ b/module/vcomponent/recurrence/parse.scm @@ -1,8 +1,6 @@ (define-module (vcomponent recurrence parse) #:duplicates (last) ; Replace @var{count} - #:export (parse-recurrence-rule) - #:use-module (srfi srfi-1) #:use-module (srfi srfi-71) #:use-module (datetime) @@ -10,11 +8,14 @@ #:use-module (vcomponent recurrence internal) #:use-module (hnh util) #:use-module (hnh util exceptions) - #:use-module (ice-9 match)) + #:use-module (ice-9 match) + + #:export (rfc->datetime-weekday + parse-recurrence-rule)) ;; transform into weekday objects from -(define-public (rfc->datetime-weekday symbol) +(define (rfc->datetime-weekday symbol) (case symbol [(SU) sun] [(MO) mon] diff --git a/module/vcomponent/util/describe.scm b/module/vcomponent/util/describe.scm index 703ac73a..36a3f998 100644 --- a/module/vcomponent/util/describe.scm +++ b/module/vcomponent/util/describe.scm @@ -2,9 +2,10 @@ :use-module (hnh util) :use-module (srfi srfi-71) :use-module (vcomponent base) - :use-module (text util)) + :use-module (text util) + :export (describe)) -(define*-public (describe vcomponent optional: (indent 0)) +(define* (describe vcomponent optional: (indent 0)) (define ii (make-string indent #\space)) (define iii (make-string (1+ indent) #\space)) @@ -39,7 +40,6 @@ (compose symbol->string car))) (for child in (children vcomponent) - (describe child (+ indent 2))) (format #t "~aEND ~a~%" ii (type vcomponent))) diff --git a/module/vcomponent/util/group.scm b/module/vcomponent/util/group.scm index b8852975..89ec47a1 100644 --- a/module/vcomponent/util/group.scm +++ b/module/vcomponent/util/group.scm @@ -4,7 +4,9 @@ #:use-module (datetime) #:use-module (srfi srfi-41) #:use-module (srfi srfi-41 util) - #:export (group-stream get-groups-between)) + #:export (group-stream + get-groups-between + group->event-list)) ;; TODO templetize this (define-stream (group-stream in-stream) @@ -67,5 +69,5 @@ [else good-part])) -(define-public (group->event-list group) +(define (group->event-list group) (stream->list (cdr group))) diff --git a/module/vcomponent/util/instance.scm b/module/vcomponent/util/instance.scm index 2004f13e..a18085eb 100644 --- a/module/vcomponent/util/instance.scm +++ b/module/vcomponent/util/instance.scm @@ -2,7 +2,7 @@ :use-module (hnh util) :use-module (calp translation) :use-module ((vcomponent util instance methods) :select (make-instance)) - :export (global-event-object) + :export (global-event-object reload) ) @@ -14,6 +14,6 @@ (define-once global-event-object (make-instance ((@ (vcomponent config) calendar-files)))) -(define-public (reload) +(define (reload) (begin (set! global-event-object (make-instance ((@ (vcomponent config) calendar-files)))) (format (current-error-port) (_ "Reload done~%")))) diff --git a/module/vcomponent/util/instance/methods.scm b/module/vcomponent/util/instance/methods.scm index 7a1d2fc8..193a0304 100644 --- a/module/vcomponent/util/instance/methods.scm +++ b/module/vcomponent/util/instance/methods.scm @@ -15,7 +15,9 @@ :use-module (calp translation) - :export (add-event + :export (load-calendars + + add-event remove-event make-instance @@ -33,7 +35,7 @@ add-calendars )) -(define-public (load-calendars calendar-files) +(define (load-calendars calendar-files) (map parse-cal-path calendar-files)) diff --git a/module/vcomponent/util/parse-cal-path.scm b/module/vcomponent/util/parse-cal-path.scm index 4baa647e..cf03db88 100644 --- a/module/vcomponent/util/parse-cal-path.scm +++ b/module/vcomponent/util/parse-cal-path.scm @@ -6,11 +6,12 @@ :use-module ((vcomponent formats ical parse) :select (parse-calendar)) :use-module ((vcomponent formats vdir parse) - :select (parse-vdir))) + :select (parse-vdir)) + :export (parse-cal-path)) ;; Parse a vdir or ics file at the given path. -(define-public (parse-cal-path path) +(define (parse-cal-path path) ;; TODO check (access? path R_OK) ? (define st (stat path)) (define cal diff --git a/module/vcomponent/util/search.scm b/module/vcomponent/util/search.scm index 61e81eb5..e2057e9e 100644 --- a/module/vcomponent/util/search.scm +++ b/module/vcomponent/util/search.scm @@ -32,7 +32,20 @@ :use-module (srfi srfi-41 util) :use-module ((ice-9 sandbox) :select (make-sandbox-module - all-pure-bindings))) + all-pure-bindings)) + :export (prepare-string + build-query-proc + execute-query + prepare-query + + paginator? + get-query get-max-page true-max-page? + + next-page + paginator->list + paginator->sub-list + + get-page)) ;; Takes a string and appends closing parenthese until all parenthese are @@ -49,7 +62,7 @@ ;; Prepares a string to be sent to build-query-proc ;; sexp-like string -> sexp -(define-public (prepare-string str) +(define (prepare-string str) (call-with-input-string (close-parenthese str) read)) ;; TODO place this in a proper module @@ -64,7 +77,7 @@ ;; eval-in-sandbox is possibly slow, and that would prevent easy caching by the ;; caller. ;; sexp -> (event → bool) -(define-public (build-query-proc . expressions) +(define (build-query-proc . expressions) ;; TODO does this eval help? Or will the body of the procedure ;; be evalutade later? (eval `(lambda (event) ,@expressions) @@ -80,7 +93,7 @@ ;; Returns a new stream which is the result of filtering the input set with the ;; query procedure. ;; (a → bool), (stream a) → (stream a) -(define-public (execute-query query-proc event-set) +(define (execute-query query-proc event-set) (stream-timeslice-limit (stream-filter query-proc event-set) ;; .5s, tested on my laptop. .1s sometimes doesn't get to events on @@ -89,7 +102,7 @@ ;; Creates a prepared query wrappend in a paginator. ;; (event → bool), (stream event) → <paginator> -(define*-public (prepare-query query-proc event-set optional: (page-size 10)) +(define* (prepare-query query-proc event-set optional: (page-size 10)) (make-paginator (stream-paginate (execute-query query-proc event-set) page-size))) @@ -106,29 +119,27 @@ (define (unset-true-max-page! paginator) (%set-true-max-page! paginator #f)) -(export paginator? get-query get-max-page true-max-page?) - (define (make-paginator query) (make-paginator% query 0 #f)) ;; a fancy version of 1+ which caps at max page ;; <paginator>, int → int -(define*-public (next-page paginator optional: (page (get-max-page paginator))) +(define* (next-page paginator optional: (page (get-max-page paginator))) (if (true-max-page? paginator) (min (1+ page) (get-max-page paginator)) (1+ page))) -(define-public (paginator->list paginator proc tail-proc) +(define (paginator->list paginator proc tail-proc) (if (true-max-page? paginator) (map proc (iota (1+ (get-max-page paginator)))) (append (map proc (iota (1+ (get-max-page paginator)))) (list (tail-proc (next-page paginator)))))) -(define*-public (paginator->sub-list paginator current-page proc - key: head-proc tail-proc - (ahead 5) (behind 5) - ) +(define* (paginator->sub-list paginator current-page proc + key: head-proc tail-proc + (ahead 5) (behind 5) + ) (let ((start (max 0 (- current-page behind))) (end (min (+ current-page ahead) @@ -143,7 +154,7 @@ ;; returns the contents of the requested page, or throws 'max-page with the ;; highest known available page. ;; <paginator>, int → (list event) throws ('max-page <int>) -(define-public (get-page paginator page) +(define (get-page paginator page) (catch 'wrong-type-arg (lambda () (let ((q (get-query paginator))) (if (stream-null? q) diff --git a/module/vulgar.scm b/module/vulgar.scm index 5e32baa5..ed24ee97 100644 --- a/module/vulgar.scm +++ b/module/vulgar.scm @@ -8,13 +8,13 @@ #:use-module (srfi srfi-60) #:use-module (vulgar termios) #:use-module (hnh util) - #:export (with-vulgar)) + #:export (cls set-cursor-pos with-vulgar)) -(define-public (cls) +(define (cls) ;; [H]ome, [J]: clear everything after (display "\x1b[H\x1b[J")) -(define-public (set-cursor-pos x y) +(define (set-cursor-pos x y) (format #t "\x1b[~a;~aH" (1+ y) (1+ x))) diff --git a/module/vulgar/color.scm b/module/vulgar/color.scm index 368a823c..5f9fbe40 100644 --- a/module/vulgar/color.scm +++ b/module/vulgar/color.scm @@ -1,5 +1,5 @@ (define-module (vulgar color) - :export (color-if)) + :export (color-if color-escape)) (define-public STR-YELLOW "\x1b[0;33m") (define-public STR-RESET "\x1b[m") @@ -11,7 +11,7 @@ (begin body ...) (if pred-value STR-RESET "")))) -(define-public (color-escape n) +(define (color-escape n) (cond ((not n) "") ((char=? #\# (string-ref n 0)) (let* ((str (string-drop n 1)) diff --git a/module/vulgar/components.scm b/module/vulgar/components.scm index 740e64c3..3242ec8c 100644 --- a/module/vulgar/components.scm +++ b/module/vulgar/components.scm @@ -1,9 +1,9 @@ (define-module (vulgar components) #:use-module (datetime) #:use-module (hnh util) - #:export ()) + #:export (display-calendar-header!)) -(define-public (display-calendar-header! date) +(define (display-calendar-header! date) (let ((day (number->string (day date))) (month (number->string (month date))) (year (number->string (year date)))) diff --git a/module/vulgar/info.scm b/module/vulgar/info.scm index 0f55c942..04c19c24 100644 --- a/module/vulgar/info.scm +++ b/module/vulgar/info.scm @@ -1,10 +1,11 @@ (define-module (vulgar info) :use-module ((srfi srfi-1) :select (car+cdr)) - :use-module (srfi srfi-71)) + :use-module (srfi srfi-71) + :export (get-terminal-size)) ;; Sort-of backwards subprocess call since we want the current terminal to be ;; inherited by stty -(define-public (get-terminal-size) +(define (get-terminal-size) (let ((rpipe wpipe (car+cdr (pipe)))) (system (format #f "stty size > /proc/~s/fd/~s" (getpid) (port->fdes wpipe))) diff --git a/module/vulgar/termios.scm b/module/vulgar/termios.scm index aa26da65..713c9875 100644 --- a/module/vulgar/termios.scm +++ b/module/vulgar/termios.scm @@ -10,7 +10,10 @@ :use-module (hnh util) :export (make-termios copy-termios - tcsetattr! tcgetattr! cfmakeraw!)) + tcsetattr! tcgetattr! cfmakeraw! + + iflag oflag cflag lflag line cc ispeed ospeed + )) @@ -106,14 +109,14 @@ (list-set! lst idx v) (set-list! t lst))))) -(define-public iflag (make-termios-accessor 0)) -(define-public oflag (make-termios-accessor 1)) -(define-public cflag (make-termios-accessor 2)) -(define-public lflag (make-termios-accessor 3)) -(define-public line (make-termios-accessor 4)) -(define-public cc (make-termios-accessor 5)) -(define-public ispeed (make-termios-accessor 6)) -(define-public ospeed (make-termios-accessor 7)) +(define iflag (make-termios-accessor 0)) +(define oflag (make-termios-accessor 1)) +(define cflag (make-termios-accessor 2)) +(define lflag (make-termios-accessor 3)) +(define line (make-termios-accessor 4)) +(define cc (make-termios-accessor 5)) +(define ispeed (make-termios-accessor 6)) +(define ospeed (make-termios-accessor 7)) diff --git a/module/web/http/make-routes.scm b/module/web/http/make-routes.scm index f5277ca5..3005200b 100644 --- a/module/web/http/make-routes.scm +++ b/module/web/http/make-routes.scm @@ -1,16 +1,17 @@ (define-module (web http make-routes) - :export (make-routes) :use-module (hnh util) :use-module (ice-9 regex) :use-module (ice-9 match) :use-module (ice-9 curried-definitions) :use-module (srfi srfi-1) :use-module (srfi srfi-71) + :export (parse-endpoint-string + make-routes) ) -(define-public (parse-endpoint-string str) +(define (parse-endpoint-string str) (let ((rx (make-regexp ":([^/.]+)(\\{([^}]+)\\})?([.])?"))) (let loop ((str str) (string "") diff --git a/module/web/query.scm b/module/web/query.scm index 2d62b45d..4a1abf66 100644 --- a/module/web/query.scm +++ b/module/web/query.scm @@ -2,9 +2,10 @@ :use-module (hnh util) :use-module (srfi srfi-1) :use-module (srfi srfi-71) - :use-module (web uri)) + :use-module (web uri) + :export (parse-query)) -(define*-public (parse-query query-string optional: (encoding "UTF-8")) +(define* (parse-query query-string optional: (encoding "UTF-8")) (unless (or (not query-string) (string-null? query-string)) (fold (lambda (str list) ;; only split on the first equal. diff --git a/module/web/uri-query.scm b/module/web/uri-query.scm index 56f3aef9..adf99803 100644 --- a/module/web/uri-query.scm +++ b/module/web/uri-query.scm @@ -1,6 +1,7 @@ (define-module (web uri-query) :use-module ((hnh util) :select (->quoted-string)) :use-module ((web uri) :select (uri-encode)) + :export (encode-query-parameters) ) ;; TODO why this format for values? @@ -8,7 +9,7 @@ ;; TODO why isn't this in the same module as `parse-query'? ;; TODO why isn't this on the same format as `parse-query'? -(define-public (encode-query-parameters parameters) +(define (encode-query-parameters parameters) (string-join (map (lambda (p) (format #f "~a=~a" |