cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add support for select elements to form-horizontal-control

Browse source
This commit is contained in:
Christopher Baines 2019-05-11 20:36:37 +01:00
parent 94e321ec38
commit 512a583fa7
1 changed files with 78 additions and 46 deletions
Download patch file Download diff file Expand all files Collapse all files

124
guix-data-service/web/view/html.scm
View file

@ -96,9 +96,13 @@
(define* (form-horizontal-control label query-parameters (define* (form-horizontal-control label query-parameters
#:key help-text (required? #f)) #:key
help-text
required?
options)
(define (value->text value) (define (value->text value)
(match value (match value
(#f "")
((? date? date) ((? date? date)
(date->string date "~1 ~3")) (date->string date "~1 ~3"))
(other other))) (other other)))
@ -111,51 +115,79 @@
(string-downcase label))) (string-downcase label)))
(has-error? (invalid-query-parameter? (has-error? (invalid-query-parameter?
(assq-ref query-parameters (assq-ref query-parameters
(string->symbol input-name))))) (string->symbol input-name))))
`(div (@ (class ,(string-append (show-help-span?
"form-group form-group-lg" (or help-text has-error? required?)))
(if has-error? " has-error" "")))) `(div
(label (@ (for ,input-id) (@ (class ,(string-append
(class "col-sm-2 control-label")) "form-group form-group-lg"
,label) (if has-error? " has-error" ""))))
(div (@ (class "col-sm-9")) (label (@ (for ,input-id)
(input (@ (class "form-control") (class "col-sm-2 control-label"))
(style "font-family: monospace;") ,label)
(id ,input-id) (div
,@(if required? (@ (class "col-sm-9"))
'((required #t)) ,(if options
'()) `(select (@ (class "form-control")
,@(if help-text (style "font-family: monospace;")
`((aria-describedby ,help-span-id)) (multiple #t)
'()) (id ,input-id)
(name ,input-name) ,@(if show-help-span?
,@(match (assq (string->symbol input-name) `((aria-describedby ,help-span-id))
query-parameters) '())
(#f '())
((_key . ($ <invalid-query-parameter> value)) (name ,input-name))
`((value ,(value->text value)))) ,@(let ((selected-options
((_key . value) (match (assq (string->symbol input-name)
`((value ,(value->text value))))))) query-parameters)
,@(if (or help-text has-error? required?) ((_key . value)
`((span (@ (id ,help-span-id) value)
(class "help-block")) (_ '()))))
,@(if required? '((strong "Required.")) '())
,@(if has-error? (map (lambda (option-value)
(let ((message `(option
(invalid-query-parameter-message (@ ,@(if (member option-value selected-options)
(assq-ref query-parameters '((selected ""))
(string->symbol input-name))))) '()))
`((p (strong ,(value->text option-value)))
,(string-append options)))
"Error: " `(input (@ (class "form-control")
(if message (style "font-family: monospace;")
message (id ,input-id)
"invalid value.")))))) ,@(if required?
'()) '((required #t))
,@(if help-text '())
(list help-text) ,@(if show-help-span?
'()))) `((aria-describedby ,help-span-id))
'()))))) '())
(name ,input-name)
,@(match (assq (string->symbol input-name)
query-parameters)
(#f '())
((_key . ($ <invalid-query-parameter> value))
`((value ,(value->text value))))
((_key . value)
`((value ,(value->text value))))))))
,@(if show-help-span?
`((span (@ (id ,help-span-id)
(class "help-block"))
,@(if has-error?
(let ((message
(invalid-query-parameter-message
(assq-ref query-parameters
(string->symbol input-name)))))
`((p (strong
,(string-append
"Error: "
(if message
message
"invalid value."))))))
'())
,@(if required? '((strong "Required. ")) '())
,@(if help-text
(list help-text)
'())))
'())))))
(define (index git-repositories-and-revisions) (define (index git-repositories-and-revisions)
(layout (layout