kabonky/widgets.scm

(define *widgets* (widgets))
(define *widget-rules* (widget-rules))

(define-syntax with-widgets
  (syntax-rules ()
    ((_ widgets* widget-rules* body ...)
     (parameterize ((widgets widgets*) (widget-rules widget-rules*))
       body ...))))

;; Make defining widgets less cumbersome and prevent conflicting
;; transform definitions that are hard to debug.
(define (widget name _markup _attributes)
  (parameterize ((widgets *widgets*) (widget-rules *widget-rules*))
    (add-widget name `((markup . `(*TOP* ,(begin (use uri-common general-utils srfi-19 (prefix utf8 utf8:) (prefix utf8-srfi-13 utf8:)) ,_markup)))
                       (attributes . ,_attributes))
                (interaction-environment))
    (set! *widgets* (widgets))
    (set! *widget-rules* (widget-rules))))

(widget
 'stylesheet
 ``(link (@ (href ,path) (type "text/css")
            (rel "stylesheet")))
 `((path "")))

(widget
 'row
 ``(div (@ (class ,(string-append "row" (if no-padding " collapse" "") " " class)) (style ,style) (id ,(if id id "")))
        ,@contents)
 `((no-padding #f) (style ()) (class "") (id #f)))

(widget
 'col
 ``(div (@ (class ,(string-append class " "
                                  (if large (string-append " large-" (number->string large)) "")
                                  (if medium (string-append " medium-" (number->string medium)) "")
                                  (if small (string-append " small-" (number->string small)) "")
                                  (if large-offset
                                      (string-append " large-offset-" (number->string large-offset))
                                      "")
                                  (if medium-offset
                                      (string-append " medium-offset-" (number->string medium-offset))
                                      "")
                                  (if small-offset
                                      (string-append " small-offset-" (number->string small-offset))
                                      "")
                                  " columns"))
           (id ,(if id id ""))) ,@contents)
 `((large #f) (medium #f) (small #f) (large-offset #f) (medium-offset #f) (small-offset #f)
   (class "") (id #f)))

(widget
 'col-end
 ``(div (@ (class "column end")) "")
 `())

(widget
 'column-layout
 `(let ((class (++ "column small-"
                   (number->string
                    (inexact->exact (round (/ 12 (or cols (length contents)))))))))
    `(div (@ (class ,(++ "row" (if padding "" " collapse"))))
          ,@(map (lambda (col)
                   `(div (@ (class ,class)) ,col))
                 contents)
          ,(if fill-row `(div (@ (class "column end"))) "")))
 `((fill-row #t) (cols #f) (padding #t)))

(widget
 'row-layout
 ``(div
    ,@(map (lambda (r) `(row (@ (no-padding ,(not padding))) (col (@ (small 12)) ,r)))
           contents))
 '((padding #t)))

(widget
 'panel
 ``(div (@ (class "panel")) ,@contents)
 `())

(widget
 'panel-small
 ``(div (@ (class "panel panel-small")) ,@contents)
 `())

(widget
 'text-center
 ``(div (@ (class "text-center")) ,@contents)
 `())

(widget
 'group-box
 ``(div (@ (class "panel group-box"))
        (h4 (@ (class "group-box-title")) ,title)
        ,@contents)
 `((title "")))

(widget
 'radio-button
 ``(label (input (@ (type "radio") (name ,name))) ,label)
 `((name "radio1") (label "radio1")))

(widget
 'spacer
 ``(div (@ (class ,(if (eq? placement 'vertical)
                       "vertical-spacer"
                       "horizontal-spacer"))) ,@contents)
 `((placement vertical)))

(widget
 'modal
 ``(div (@ (class "modal-overlay"))
        (div (@ (class "modal-content"))
             ,@contents))
 `())

(widget
 'external-link
 ``(a (@ (href ,href)) ,@contents)
 `((href "")))

(widget
 'select-box
 ``(select (@ (name ,select-name) ,type ,@attrs)
     ,@(map
        (lambda (o)
          `(option (@ (name ,(or (and (list? o) (alist-ref 'name o)) o))
                      ,@(or (and (list? o) (alist-ref 'selected o)
                                 '(selected))
                            '()))
                   ,(or (and (list? o) (alist-ref 'body o)) o)))
        contents))
 '((select-name "") (type "") (attrs '())))

(widget
 'nav-bar-title
 ``(ul (@ (class "title-area"))
       (li (@ (class "name"))
           ,(if title `(h1 (a (@ (href ,url)) ,title)) ""))
       (li (@ (class "toggle-topbar menu-icon"))
           (a (@ (href "#")) (span "Menu"))))
 '((title #f) (url "#")))

(widget
 'nav-bar-section
 ``(ul ,@(if (eq? float 'right) '((@ (class "right"))) '())
       ,@contents)
 '((float #f)))

(widget
 'nav-bar-item
 ``(li (@ (class ,(if active "active" "")))
       (a (@ (href ,url)) ,@contents))
 '((active #f) (url "#")))

(widget
 'nav-bar-dropdown-item
 ``(li (@ (class ,(++ "has-dropdown " (if active "active" ""))))
       (a (@ (href ,url)) ,title)
       (ul (@ (class "dropdown"))
           ,@contents))
 '((active #f) (url "#") (title "")))

(widget
 'nav-bar
 ``(div (@ (class "contain-to-grid"))
        (nav (@ (class "top-bar") data-topbar (role "navigation")
                (data-options "is_hover: true"))
             ,@(if title `(,title) '())
             (section (@ (class "top-bar-section"))
                      ,@contents)))
 '((title #f)))

(widget
 'sub-nav-item
 ``(dd (@ ,@(if active '((class "active")) '()))
       ,@contents)
 '((active #f)))

(widget
 'sub-nav
 ``(dl (@ (class "sub-nav"))
       (dt ,label)
       ,@contents)
 '((label "")))