From f6fe653f668b61739922e0207ae9ba59cda0c2e4 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sun, 9 Nov 2014 09:21:55 -0500 Subject: [PATCH] Clean up repetition and boilerplate in markup. --- src/bootstrap.rkt | 51 +++---- src/main.rkt | 337 ++++++++++++++++++-------------------------- src/xexpr-utils.rkt | 35 +++++ 3 files changed, 190 insertions(+), 233 deletions(-) create mode 100644 src/xexpr-utils.rkt diff --git a/src/bootstrap.rkt b/src/bootstrap.rkt index 7c4a364..8aa3cc7 100644 --- a/src/bootstrap.rkt +++ b/src/bootstrap.rkt @@ -13,15 +13,15 @@ bootstrap-response bootstrap-redirect - bootstrap-radio - bootstrap-fieldset - bootstrap-button + add-classes glyphicon) (require racket/match) +(require racket/string) (require web-server/servlet) (require "html-utils.rkt") +(require "xexpr-utils.rkt") (define bootstrap-project-name (make-parameter "Project")) (define bootstrap-project-link (make-parameter "/")) @@ -33,6 +33,7 @@ (define bootstrap-page-scripts (make-parameter '())) (define bootstrap-cookies (make-parameter '())) +;; String [#:title-element XExpr] [#:code Integer] [#:message Bytes] [XExpr ...] -> Response (define (bootstrap-response title #:title-element [title-element `(h1 ,title)] #:code [code 200] @@ -80,6 +81,7 @@ ,@(for/list ((script (bootstrap-page-scripts))) `(script ((type "text/javascript") (src ,script)))))))) +;; String [#:permanent? Boolean] [#:headers (Listof Header)] -> Response (define (bootstrap-redirect url #:permanent? [permanent? #f] #:headers [headers '()]) @@ -88,33 +90,22 @@ #:headers (append (map cookie->header (bootstrap-cookies)) headers))) -;; String String XExpr ... -> XExpr -;; Constructs Bootstrap boilerplate for a radio button. -(define (bootstrap-radio #:checked [checked #f] field-name field-value . label-contents) - `(label ((class "radio")) - (input ((type "radio") - (name ,field-name) - (value ,field-value) - ,@(maybe-splice checked '(checked "checked")))) - ,@label-contents)) - -;; [#:legend (Option String)] [#:style Style] XExpr ... -> XExpr -;; where Style is one of 'inline, 'horizontal, or 'normal. -(define (bootstrap-fieldset #:legend [legend #f] - #:style [style 'normal] - . contents) - `(fieldset - ,@(maybe-splice legend `(legend ,legend)) - ,@contents)) - -;; [#:id (Option String)] [#:type (Option String)] XExpr ... -> XExpr -(define (bootstrap-button #:id [id #f] - #:type [type "submit"] - . contents) - `(button ((class "btn") - ,@(maybe-splice id `(id ,id)) - ,@(maybe-splice type `(type ,type))) - ,@contents)) +;; (Listof (U Symbol String)) XExpr -> XExpr +(define (add-classes classes x) + (define class-strs (map (lambda (c) (if (symbol? c) (symbol->string c) c)) classes)) + (xexpr-case x + (lambda (content) + `(span ((class ,(string-join class-strs))) ,content)) + (lambda (tag attrs kids) + (match (assq 'class attrs) + [#f + `(,tag ((class ,(string-join class-strs)) + ,@attrs) + ,@kids)] + [(and (list 'class existing-class) entry) + `(,tag ((class ,(string-join (cons existing-class class-strs))) + ,@(remove entry attrs)) + ,@kids)])))) ;; Symbol -> XExpr (define (glyphicon type) diff --git a/src/main.rkt b/src/main.rkt index a7cb91a..a583f69 100644 --- a/src/main.rkt +++ b/src/main.rkt @@ -189,6 +189,57 @@ (cons 'passwd password) (cons 'code code)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define ((generic-input type) name [initial-value ""] #:placeholder [placeholder #f]) + `(input ((class "form-control") + (type ,type) + (name ,name) + (id ,name) + ,@(maybe-splice placeholder `(placeholder ,placeholder)) + (value ,initial-value)))) + +(define email-input (generic-input "email")) +(define password-input (generic-input "password")) +(define text-input (generic-input "text")) + +(define (label for . content) + `(label ((class "control-label") ,@(maybe-splice for `(for ,for))) + ,@content)) + +(define (primary-button . content) + `(button ((type "submit") + (class "btn btn-primary")) + ,@content)) + +(define (generic-row class) + (define (wrap cell) + (match cell + [(cons 'label _) cell] + [_ `(div ,cell)])) + (lambda (#:id [id #f] . args) + `(div (,@(maybe-splice id `(id ,id)) + (class ,class)) + ,@(let loop ((args args)) + (match args + [(list* _ _ #f rest) + (loop rest)] + [(list* 0 0 cell rest) + (cons cell (loop rest))] + [(list* 0 w cell rest) + (cons (add-classes (list (format "col-sm-~a" w)) (wrap cell)) + (loop rest))] + [(list* o w cell rest) + (cons (add-classes (list (format "col-sm-offset-~a col-sm-~a" o w)) (wrap cell)) + (loop rest))] + ['() + '()]))))) + +(define form-group (generic-row "form-group")) +(define row (generic-row "row")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (define (login-page [error-message #f]) (send/suspend/dispatch (lambda (embed-url) @@ -197,40 +248,19 @@ (method "post") (action ,(embed-url process-login-credentials)) (role "form")) - (div ((class "form-group")) - (label ((class "col-sm-offset-2 col-sm-2 control-label") - (for "email")) "Email address:") - (div ((class "col-sm-5")) - (input ((class "form-control") - (type "email") - (name "email") - (value "") - (id "email"))))) - (div ((class "form-group")) - (label ((class "col-sm-offset-2 col-sm-2 control-label") - (for "password")) "Password:") - (div ((class "col-sm-5")) - (input ((class "form-control") - (type "password") - (name "password") - (value "") - (id "password"))))) - (div ((class "form-group")) - (div ((class "col-sm-offset-4 col-sm-5")) - (a ((href ,(embed-url (lambda (req) (register-page))))) - "Need to reset your password?"))) + ,(form-group 2 2 (label "email" "Email address") + 0 5 (email-input "email")) + ,(form-group 2 2 (label "password" "Password:") + 0 5 (password-input "password")) + ,(form-group 4 5 + `(a ((href ,(embed-url (lambda (req) (register-page))))) + "Need to reset your password?")) ,@(maybe-splice error-message - `(div ((class "form-group")) - (div ((class "col-sm-offset-4 col-sm-5")) - (div ((class "alert alert-danger")) - (p ,error-message))))) - (div ((class "form-group")) - (div ((class "col-sm-offset-4 col-sm-5")) - (button ((type "submit") - (class "btn btn-primary")) - "Log in")))) - )))) + (form-group 4 5 + `(div ((class "alert alert-danger")) + (p ,error-message)))) + ,(form-group 4 5 (primary-button "Log in"))))))) (define (process-login-credentials request) (define-form-bindings request (email password)) @@ -259,53 +289,20 @@ (method "post") (action ,(embed-url apply-account-code)) (role "form")) - (div ((class "form-group")) - (label ((class "col-sm-offset-2 col-sm-2 control-label") - (for "email")) "Email address:") - (div ((class "col-sm-5")) - (input ((class "form-control") - (type "email") - (name "email") - (value ,email) - (id "email"))))) - (div ((class "form-group")) - (label ((class "col-sm-offset-2 col-sm-2 control-label") - (for "code")) "Code:") - (div ((class "col-sm-5")) - (input ((class "form-control") - (type "text") - (name "code") - (value ,code) - (id "code"))))) - (div ((class "form-group")) - (label ((class "col-sm-offset-2 col-sm-2 control-label") - (for "password")) "Password:") - (div ((class "col-sm-5")) - (input ((class "form-control") - (type "password") - (name "password") - (value "") - (id "password"))))) - (div ((class "form-group")) - (label ((class "col-sm-offset-2 col-sm-2 control-label") - (for "password")) "Confirm password:") - (div ((class "col-sm-5")) - (input ((class "form-control") - (type "password") - (name "confirm_password") - (value "") - (id "confirm_password"))))) + ,(form-group 2 2 (label "email" "Email address") + 0 5 (email-input "email" email)) + ,(form-group 2 2 (label "code" "Code") + 0 5 (text-input "code" code)) + ,(form-group 2 2 (label "password" "Password") + 0 5 (password-input "password")) + ,(form-group 2 2 (label "password" "Confirm password") + 0 5 (password-input "confirm_password")) ,@(maybe-splice error-message - `(div ((class "form-group")) - (div ((class "col-sm-offset-4 col-sm-5")) - (div ((class "alert alert-danger")) - (p ,error-message))))) - (div ((class "form-group")) - (div ((class "col-sm-offset-4 col-sm-5")) - (button ((type "submit") - (class "btn btn-primary")) - "Continue"))))) + (form-group 4 5 + `(div ((class "alert alert-danger")) + (p ,error-message)))) + ,(form-group 4 5 (primary-button "Continue")))) `(div (h1 "Need a code?") (p "Enter your email address below, and we'll send you one.") @@ -313,20 +310,9 @@ (method "post") (action ,(embed-url notify-of-emailing)) (role "form")) - (div ((class "form-group")) - (label ((class "col-sm-offset-2 col-sm-2 control-label") - (for "email")) "Email address:") - (div ((class "col-sm-5")) - (input ((class "form-control") - (type "email") - (name "email_for_code") - (value "") - (id "email_for_code"))))) - (div ((class "form-group")) - (div ((class "col-sm-offset-4 col-sm-5")) - (button ((type "submit") - (class "btn btn-primary")) - "Email me a code"))))))))) + ,(form-group 2 2 (label "email" "Email address") + 0 5 (email-input "email_for_code")) + ,(form-group 4 5 (primary-button "Email me a code")))))))) (define (apply-account-code request) (define-form-bindings request (email code password confirm_password)) @@ -497,14 +483,7 @@ " packages in the index.") (form ((role "form") (action ,(named-url search-page))) - (div ((class "form-group")) - (input ((class "form-control") - (type "text") - (placeholder "Search packages") - (name "q") - (value "") - (id "q")))) - )) + ,(text-input "q" #:placeholder "Search packages"))) (package-summary-table package-name-list))))) (define (logout-page request) @@ -730,22 +709,12 @@ (match-define (list version source) v) (define (control-name c) (format "version__~a__~a" version c)) (define (group-name c) (format "version__~a__~a__group" version c)) - (define (textfield name label value [placeholder ""]) - `(div ((id ,(group-name name)) - (class "row")) - ,@(maybe-splice - label - `(div ((class "col-sm-3")) - (label ((class "control-label") - (for ,(control-name name))) - ,label))) - (div ((class ,(if label "col-sm-9" "col-sm-12"))) - (input ((class "form-control") - (type "text") - (name ,(control-name name)) - (id ,(control-name name)) - (placeholder ,placeholder) - (value ,value)))))) + (define (textfield name label-text value [placeholder ""]) + (row #:id (group-name name) + 0 3 + (and label-text (label (control-name name) label-text)) + 0 (if label-text 9 12) + (text-input (control-name name) value #:placeholder placeholder))) (define-values (source-type simple-url g-host g-user g-project g-branch) (match source [(pregexp #px"github://github\\.com/([^/]*)/([^/]*)(/([^/]*)/?)?" @@ -766,45 +735,38 @@ (name "action") (value ,(control-name "delete"))) ,(glyphicon 'trash)))) - (td (div ((class "row")) - (div ((class "col-sm-3")) - (div ((id ,(group-name "type"))) - (select ((class "package-version-source-type") - (data-packageversion ,version) - (name ,(control-name "type"))) - ,(package-source-option source-type - "github" - "Github Repository") - ,(package-source-option source-type - "git" - "Git Repository") - ,(package-source-option source-type - "simple" - "Simple URL")))) - (div ((id ,(group-name "fields")) - (class "col-sm-9")) - (div ((id ,(group-name "urlpreview")) - (class "row")) - (div ((class "col-sm-3")) - (label ((class "control-label")) "URL preview")) - (div ((class "col-sm-9")) - (span ((class "form-control disabled") - (disabled "disabled") - (id ,(control-name "urlpreview")))))) - ,(textfield "simple_url" #f simple-url) - ,(textfield "g_host" "Repo Host" g-host) - ,(textfield "g_user" "Repo User" g-user) - ,(textfield "g_project" "Repo Project" g-project) - ,(textfield "g_branch" "Repo Branch" g-branch "master") - ))))) + (td ,(row + 0 3 `(div ((id ,(group-name "type"))) + (select ((class "package-version-source-type") + (data-packageversion ,version) + (name ,(control-name "type"))) + ,(package-source-option source-type + "github" + "Github Repository") + ,(package-source-option source-type + "git" + "Git Repository") + ,(package-source-option source-type + "simple" + "Simple URL"))) + 0 9 `(div ((id ,(group-name "fields"))) + (div ((id ,(group-name "urlpreview")) + (class "row")) + (div ((class "col-sm-3")) + ,(label #f "URL preview")) + (div ((class "col-sm-9")) + (span ((class "form-control disabled") + (disabled "disabled") + (id ,(control-name "urlpreview")))))) + ,(textfield "simple_url" #f simple-url) + ,(textfield "g_host" "Repo Host" g-host) + ,(textfield "g_user" "Repo User" g-user) + ,(textfield "g_project" "Repo Project" g-project) + ,(textfield "g_branch" "Repo Branch" g-branch "master")))))) + (tr (td ((colspan "2")) (div ((class "form-inline")) - (input ((class "form-control") - (type "text") - (name "new_version") - (id "new_version") - (placeholder "x.y.z") - (value ""))) + ,(text-input "new_version" #:placeholder "x.y.z") " " (button ((class "btn btn-success btn-xs") (type "submit") @@ -830,37 +792,22 @@ (div ((class "container")) ;; TODO: remove?? (div ((class "row")) (div ((class "form-group col-sm-6")) - (label ((for "name") - (class "control-label")) - "Package Name") - (input ((class "form-control") - (type "text") - (name "name") - (id "name") - (value ,(~a (draft-package-name draft)))))) + ,(label "name" "Package Name") + ,(text-input "name" (~a (draft-package-name draft)))) (div ((class "form-group col-sm-6")) - (label ((for "tags") - (class "control-label")) - "Package Tags (space-separated)") - (input ((class "form-control") - (type "text") - (name "tags") - (id "tags") - (value ,(string-join - (draft-package-tags draft))))))) + ,(label "tags" "Package Tags (space-separated)") + ,(text-input "tags" (string-join + (draft-package-tags draft))))) (div ((class "row")) (div ((class "form-group col-sm-6")) - (label ((for "description") - (class "control-label")) - "Package Description") + ,(label "description" "Package Description") (textarea ((class "form-control") (name "description") (id "description")) ,(draft-package-description draft))) (div ((class "form-group col-sm-6")) - (label ((for "authors") - (class "control-label")) - "Author email addresses (one per line)") + ,(label "authors" + "Author email addresses (one per line)") (textarea ((class "form-control") (name "authors") (id "authors")) @@ -868,8 +815,7 @@ "\n")))) (div ((class "row")) (div ((class "form-group col-sm-12")) - (label ((class "control-label")) - "Package Versions & Sources") + ,(label #f "Package Versions & Sources") ,(build-versions-table))) (div ((class "row")) (div ((class "form-group col-sm-12")) @@ -1118,35 +1064,20 @@ (bootstrap-response "Search Racket Package Index" `(form ((class "form-horizontal") (role "form")) - (div ((class "form-group")) - (label ((class "col-sm-2 control-label") - (for "q")) "Search terms") - (div ((class "col-sm-10")) - (input ((class "form-control") - (type "text") - (placeholder "Enter free-form text to match here") - (name "q") - (value ,search-text) - (id "q"))))) - (div ((class "form-group")) - (label ((class "col-sm-2 control-label") - (for "tags")) "Tags") - (div ((class "col-sm-10")) - (input ((class "form-control") - (type "text") - (placeholder "tag1 tag2 tag3 ...") - (name "tags") - (value ,tags-input) - (id "tags"))))) - (div ((class "form-group")) - (div ((class "col-sm-offset-2 col-sm-10")) - (button ((type "submit") - (class "btn btn-primary")) - ,(glyphicon 'search) " Search"))) + ,(form-group 0 2 (label "q" "Search terms") + 0 10 (text-input "q" search-text + #:placeholder + "Enter free-form text to match here")) + ,(form-group 0 2 (label "tags" "Tags") + 0 10(text-input "tags" tags-input + #:placeholder + "tag1 tag2 tag3 ...")) + ,(form-group 2 10 (primary-button (glyphicon 'search) " Search")) (div ((class "search-results")) ,@(maybe-splice (or (pair? tags) (not (equal? search-text ""))) (let ((package-name-list (package-search search-text tags))) `(div - (p ((class "package-count")) ,(format "~a packages found" (length package-name-list))) + (p ((class "package-count")) + ,(format "~a packages found" (length package-name-list))) ,(package-summary-table package-name-list)))))))))) diff --git a/src/xexpr-utils.rkt b/src/xexpr-utils.rkt new file mode 100644 index 0000000..5edd82c --- /dev/null +++ b/src/xexpr-utils.rkt @@ -0,0 +1,35 @@ +#lang racket/base +;; XExpr utilities + +(provide xexpr-case) +(module+ test (require rackunit)) + +(require racket/match) + +(define (xexpr-case x content element) + (match x + [(? string? s) (content s)] + [(list tag (list (list key value) ...) body ...) (element tag (map list key value) body)] + [(list tag body ...) (element tag '() body)] + [else (error 'xexpr-case "Invalid xexpr: ~a" x)])) + +(module+ test + (define (x xexpr) (xexpr-case xexpr values list)) + (check-equal? (x "hello") "hello") + + (check-equal? (x `(a)) (list 'a '() '())) + (check-equal? (x `(a ())) (list 'a '() '())) + (check-equal? (x `(a ((href "hello")))) (list 'a '((href "hello")) '())) + (check-equal? (x `(a ((href "hello") (class "foo")))) + (list 'a '((href "hello") (class "foo")) '())) + + (check-equal? (x `(div "content" (b "bold"))) + (list 'div '() '("content" (b "bold")))) + (check-equal? (x `(div () "content" (b "bold"))) + (list 'div '() '("content" (b "bold")))) + (check-equal? (x `(div ((id "hello")) "content" (b "bold"))) + (list 'div '((id "hello")) '("content" (b "bold")))) + (check-equal? (x `(div ((id "hello") (class "foo")) "content" (b "bold"))) + (list 'div '((id "hello") (class "foo")) '("content" (b "bold")))) + + )