Move html modules under calp.

3 files changed, 0 insertions, 334 deletions

diff --git a/module/html/view/calendar/month.scm b/module/html/view/calendar/month.scm
deleted file mode 100644
index 99640a22..00000000
--- a/module/html/view/calendar/month.scm
+++ /dev/null
@@ -1,117 +0,0 @@
-(define-module (html view calendar month)
-  :use-module (util)
-  :use-module (srfi srfi-1)
-  :use-module (srfi srfi-41)
-  :use-module (srfi srfi-41 util)
-  :use-module (datetime)
-  :use-module (html view calendar shared)
-  :use-module (html config)
-  :use-module (vcomponent)
-  :use-module ((vcomponent datetime)
-               :select (really-long-event?
-                        events-between))
-  :use-module ((html vcomponent)
-               :select (make-block))
-  :use-module ((vcomponent group)
-               :select (group-stream get-groups-between))
-  )
-
-;; (stream event-group) -> sxml
-(define*-public (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
-    (partition really-long-event? (stream->list (events-between pre-start post-end events))))
-
-  (define short-event-groups
-    (get-groups-between (group-stream (list->stream short-events))
-                        pre-start post-end))
-
-  (define long-event-groups
-    (map (lambda (s)
-           (define e (date+ s (date day: 6)))
-           (cons* s e
-                  (stream->list
-                   (events-between s e (list->stream long-events)))))
-         (date-range pre-start post-end (date day: 7))))
-
-  `((script "const VIEW='month';")
-    (header (@ (class "table-head"))
-            ,(string-titlecase (date->string start-date "~B ~Y")))
-    (div (@ (class "caltable")
-            (style "grid-template-rows: 2em"
-              ,(string-concatenate
-                (map (lambda (long-group)
-                       (format #f " [time] 15pt [long] ~amm [short] 1fr"
-                               (min 10 (* 4 (length (cddr long-group))))))
-                     long-event-groups))))
-         ,@(map (lambda (d) `(div (@ (class "thead")) ,(string-titlecase (week-day-name d))))
-                (weekday-list))
-         ,@(map (lambda (group i)
-                  (let* (((s e . events) group))
-                    `(div (@ (class "cal-cell longevents event-container")
-                             (style "grid-area: long " ,i ";"
-                                    "grid-column: 1 / span 7;")
-                             (data-start ,(date->string s))
-                             (data-end ,(date->string (add-day e))))
-                          ,@(lay-out-long-events
-                             s e events))))
-                long-event-groups
-                (iota (length long-event-groups) 1))
-
-         ,@(caltable-time-cells start-date end-date
-                                pre-start post-end)
-
-         ,@(stream->list
-            (stream-map
-             (lambda (group i)
-               (define day-date (car group))
-               (define events (cdr group))
-               `(div (@ (style "grid-area:short " ,i)
-                        (class "cal-cell cal-cell-short event-container")
-                        (data-start ,(date->string day-date))
-                        (data-end ,(date->string (add-day day-date))))
-                     (div (@ (style "overflow-y:auto;"))
-                      ,@(map make-small-block (stream->list events)))))
-             short-event-groups
-             (repeating-naturals 1 7)
-             )))
-
-    ;; These popups are relative the document root. Can thus be placed anywhere in the DOM.
-    ,@(for event in (stream->list
-                     (events-between start-date end-date events))
-           ((@ (html vcomponent) popup) event
-            (string-append "popup" ((@ (html util) html-id) event))))
-    ))
-
-
-
-;;; Table output
-
-(define (make-small-block event)
-  (make-block event))
-
-(define (caltable-time-cells start-date end-date
-                             pre-start post-end)
-  (map (lambda (day-date i)
-         `(div (@ (style "grid-area:time " ,i)
-                  (class "cal-cell cal-cell-time"))
-               (a (@ (class "hidelink")
-                     (href "/week/" ,(date->string day-date "~Y-~m-~d")
-                           ".html#" ,(date->string day-date "~Y-~m-~d")))
-                (time (@ (class "date-info "
-                           ,(if (or (date< day-date start-date)
-                                    (date< end-date day-date))
-                                "non-current"
-                                "current"))
-                         (datetime ,(date->string day-date "~1")))
-                      (span (@ (class "day-number"))
-                            ,(date->string day-date "~e"))
-                      ,(when (= 1 (day day-date))
-                         `(span (@ (class "month-name"))
-                                ,(date->string day-date "~b")))
-                      ,(when (= 1 (month day-date) (day day-date))
-                         `(span (@ (class "year-number"))
-                                ", " ,(date->string day-date "~Y")))))))
-       (date-range pre-start post-end)
-       (map floor (iota (length (date-range pre-start post-end)) 1 1/7))))
diff --git a/module/html/view/calendar/shared.scm b/module/html/view/calendar/shared.scm
deleted file mode 100644
index d1f58460..00000000
--- a/module/html/view/calendar/shared.scm
+++ /dev/null
@@ -1,96 +0,0 @@
-(define-module (html view calendar shared)
-  :use-module (util)
-  :use-module (srfi srfi-1)
-  :use-module (vcomponent)
-  :use-module ((vcomponent datetime)
-               :select (event-length
-                        overlapping?
-                        event-length/clamped))
-  :use-module ((vcomponent datetime output)
-               :select (format-summary))
-  :use-module (util tree)
-  :use-module (datetime)
-  :use-module (html config)
-  :use-module ((html components)
-               :select (btn tabset))
-  :use-module ((html vcomponent)
-               :select (make-block) )
-  )
-
-
-
-(define-public x-pos (make-object-property))
-(define-public width (make-object-property))
-
-
-;; 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>?))
-  ;; The tree construction is greedy. This means
-  ;; that if  a smaller  event preceeds a longer
-  ;; event it would capture  the longer event to
-  ;; only find  events which  also overlaps  the
-  ;; smaller event.
-
-  ;; @var{x} is how for left in the container we are.
-  (let inner ((x 0)
-              (tree (make-tree overlapping?
-                               (sort* lst event-length-comperator event-length-key
-                                      ))))
-    (unless (null? tree)
-      (let ((w (/ (- 1 x)
-                  (+ 1 (length-of-longst-branch (left-subtree tree))))))
-        (set! (width (car tree)) w
-              (x-pos (car tree)) x)
-        (inner (+ x w) (left-subtree tree))
-        (inner x (right-subtree tree))))))
-
-
-(define-public (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))
-       events))
-
-;; date{,time}-difference works in days, and days are simply multiplied by 24 to
-;; 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 total-length
-    (* 24 (days-in-interval start-date end-date)))
-
-  (define top (* 100 (x-pos ev)))
-  (define height (* 100 (width ev)))
-  (define left ; start time
-    (* 100
-       (let* ((dt (datetime date: start-date))
-              (diff (datetime-difference
-                     (datetime-max dt (as-datetime (prop ev 'DTSTART)))
-                     dt)))
-         (/ (datetime->decimal-hour diff start-date) total-length))))
-
-  ;; Set length of event, which makes end time
-  (define width*
-    (* 100
-       (/ (datetime->decimal-hour
-           (as-datetime (event-length/clamped start-date end-date ev))
-           start-date)
-          total-length)))
-
-  (define style
-    (if (edit-mode)
-        (format #f "top:calc(var(--editmode)*~,3f%);height:calc(var(--editmode)*~,3f%);left:~,3f%;width:~,3f%;"
-                top height left width*)
-        (format #f "top:~,3f%;height:~,3f%;left:~,3f%;width:~,3f%;"
-                top height left width*)))
-
-  (make-block
-   ev `((class
-          ,(when (date/-time< (prop ev 'DTSTART) start-date)
-             " continued")
-          ,(when (and (prop ev 'DTEND)
-                      (date/-time< (date+ end-date (date day: 1)) (prop ev 'DTEND)))
-             " continuing"))
-        (style ,style))))
diff --git a/module/html/view/calendar/week.scm b/module/html/view/calendar/week.scm
deleted file mode 100644
index 34e8eeb4..00000000
--- a/module/html/view/calendar/week.scm
+++ /dev/null
@@ -1,121 +0,0 @@
-(define-module (html view calendar week)
-  :use-module (util)
-  :use-module (srfi srfi-1)
-  :use-module (srfi srfi-41)
-  :use-module (datetime)
-  :use-module (html view calendar shared)
-  :use-module (html config)
-  :use-module (html util)
-  :use-module (vcomponent)
-  :use-module ((vcomponent datetime)
-               :select (long-event?
-                        event-length/day
-                        event-zero-length?
-                        events-between))
-  :use-module ((html vcomponent)
-               :select (make-block) )
-  :use-module ((vcomponent group)
-               :select (group-stream get-groups-between))
-  )
-
-
-(define*-public (render-calendar key: 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 "const VIEW='week';")
-      (div (@ (class "calendar"))
-           (div (@ (class "days"))
-                ,@(time-marker-div)
-                (div (@ (class "longevents event-container")
-                        (data-start ,(date->string start-date) )
-                        (data-end ,(date->string (add-day end-date)) )
-                        (style "grid-column-end: span " ,(days-in-interval start-date end-date)))
-                     ,@(lay-out-long-events start-date end-date long-events))
-                ,@(map (lambda (day-date)
-                         `(div (@ (class "meta"))
-                               (span (@ (class "daydate"))
-                                     ,(date->string day-date "~Y-~m-~d"))
-                               (span (@ (class "dayname"))
-                                     ,(string-titlecase (date->string day-date "~a")))))
-                       range)
-                ,@(stream->list
-                   (stream-map
-                    lay-out-day
-                    (get-groups-between (group-stream (list->stream short-events))
-                                        start-date end-date)))
-
-                ,@(for event in (stream->list
-                                 (events-between start-date end-date events))
-                       ((@ (html vcomponent ) popup) event (string-append "popup" (html-id event))))
-
-                )))))
-
-
-
-(define (time-marker-div)
-  ;; element to make rest of grid align correct.
-  ;; Could be extended to contain something fun.
-  `((div (@ (style "grid-row: 1 / span 2")))
-    (div (@ (class "sideclock"))
-         ,@(map (lambda (time)
-                  `(div (@ (class "clock clock-" ,time))
-                        (span (@ (class "clocktext"))
-                              ,time ":00")))
-                (iota 12 0 2)))))
-
-;; Lay out complete day (graphical)
-;; (date . (events)) -> sxml
-(define (lay-out-day day)
-  (let* (((day-date . events) day)
-         (time-obj (datetime date: day-date))
-         (zero-length-events short-events
-                             (partition event-zero-length? (stream->list events))))
-
-    (fix-event-widths! short-events event-length-key:
-                       (lambda (e) (event-length/day day-date e)))
-
-    `(div (@ (class "events event-container") (id ,(date-link day-date))
-             (data-start ,(date->string day-date))
-             (data-end ,(date->string (add-day day-date)) ))
-          ,@(map (lambda (time)
-                   `(div (@ (class "clock clock-" ,time))))
-                 (iota 12 0 2))
-          (div (@ (class "zero-width-events"))
-               ,(map make-block zero-length-events))
-          ,@(map (lambda (e) (create-block day-date e)) short-events))))
-
-
-
-;; Format single event for graphical display
-;; This is extremely simmilar to create-top-block, which currently recides in ./shared
-(define (create-block date ev)
-  ;; (define time (date->time-utc day))
-
-  (define left  (* 100 (x-pos ev)))
-  (define width* (* 100 (width ev)))
-  (define top (if (date= date (as-date (prop ev 'DTSTART)))
-                  (* 100/24
-                     (time->decimal-hour
-                      (as-time (prop ev 'DTSTART))))
-                  0))
-  (define height (* 100/24 (time->decimal-hour (event-length/day date ev))))
-
-
-  (define style
-    ;; The calc's here is to enable an "edit-mode".
-    ;; Setting --editmode ≈ 0.8 gives some whitespace to the right
-    ;; of the events, alowing draging there for creating new events.
-    (if (edit-mode)
-        (format #f "left:calc(var(--editmode)*~,3f%);width:calc(var(--editmode)*~,3f%);top:~,3f%;height:~,3f%;"
-
-                left width* top height)
-        (format #f "left:~,3f%;width:~,3f%;top:~,3f%;height:~,3f%;"
-                left width* top height)))
-
-  (make-block
-   ev `((class
-          ,(when (date<? (as-date (prop ev 'DTSTART)) date)
-             " continued")
-          ,(when (and (prop ev 'DTEND) (date<? date (as-date (prop ev 'DTEND))))
-             " continuing"))
-        (style ,style))))