Skip to content

Commit

Permalink
core: add formular forms
Browse files Browse the repository at this point in the history
  • Loading branch information
@Bogdanp
Bogdanp committed May 27, 2021
1 parent 01dfa17 commit f2916bd
Show file tree
Hide file tree
Showing 2 changed files with 143 additions and 58 deletions.
102 changes: 102 additions & 0 deletions congame-core/components/formular.rkt
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,102 @@
#lang racket/base

(require (for-syntax racket/base
racket/syntax
syntax/parse)
forms
koyo/haml
racket/match (prefix-in study: "study.rkt"))

(provide
::
formular
checkbox
radios)

(define-syntax (:: _stx)
(raise-syntax-error ':: "may only be used within a formular"))

(define-syntax (formular stx)
(syntax-parse stx
#:literals (::)
[(_ form action-e)
#:with rw (format-id stx "rw")
#:with tbl (format-id stx "tbl")
#:with ((kwd fld) ...)
(let loop ([stx #'form]
[pairs null])
(syntax-parse stx
#:literals (::)
[(:: kwd:keyword fld)
(cons #'(kwd fld) pairs)]

[(_ e ...)
(apply append (map (λ (stx) (loop stx null))
(syntax->list #'(e ...))))]

[_ pairs]))
#:with (field-id ...)
(for/list ([idx (in-naturals 1)]
[kwd (in-list (syntax-e #'(kwd ...)))])
(format-id kwd "input_~a" idx))
#:with patched-form
(let loop ([stx #'form])
(syntax-parse stx
#:literals (::)
[(:: kwd:keyword _)
#'(let ([entry (hash-ref tbl 'kwd)])
(rw (car entry) ((cdr entry) 'widget)))]

[(fn e ...)
#`(fn #,@(map loop (syntax-e #'(e ...))))]

[e #'e]))
#'(let ([action-fn action-e]
[field-id fld] ...)
(let ([tbl (make-hasheq
(list (cons 'kwd (cons (symbol->string 'field-id) field-id)) ...))])
(let ([f (form* ([field-id (field-id 'validator)] ...)
(cons
(list 'kwd ...)
(list field-id ...)))])
(study:form
f
(lambda (res)
(define vals-by-kwd
(for/hasheq ([k (in-list (car res))]
[v (in-list (cdr res))])
(values k v)))
(define sorted-kwds
(sort (car res) keyword<?))
(define sorted-vals
(for/list ([k (in-list sorted-kwds)])
(hash-ref vals-by-kwd k)))
(keyword-apply action-fn sorted-kwds sorted-vals null))
(lambda (rw)
patched-form)))))]))

(define ((checkbox label) meth)
(match meth
['validator
(ensure binding/boolean (required))]

['widget
(lambda (name value errors)
(haml
(.group
(:label ((widget-checkbox) name value errors) label)
,@((widget-errors) name value errors))))]))

(define ((radios label options #:validators [validators null]) meth)
(match meth
['validator
(apply ensure binding/text (required) validators)]

['widget
(lambda (name value errors)
(haml
(.group
(:label.radio-group
label
((widget-radio-group options) name value errors))
,@((widget-errors) name value errors))))]))
99 changes: 41 additions & 58 deletions congame-pjb-studies/pjb-pilot.rkt
View file
Original file line number Diff line number Diff line change
Expand Up @@ -15,6 +15,7 @@
sentry
(prefix-in config: congame/config)
congame/components/bot
congame/components/formular
congame/components/resource
congame/components/study
congame-pjb-studies/relax
Expand Down Expand Up @@ -179,49 +180,37 @@
(err (or message (format "Should be equal to ~a" a)))))

(define (render-comprehension-form)
(define the-form
(form* ([what-if-fail-study? (ensure
binding/text
(required)
(is-equal "no-extra-no-participation-fee"
#:message "No. You receive payment for required tasks, but not for the participation fee."))]
[how-many-required-tasks? (ensure
binding/number
(required)
(is-equal (get 'required-tasks)
#:message "No. Read the study description again."))])
(list what-if-fail-study?
how-many-required-tasks?)))

(define n-tasks (number->string (get 'required-tasks)))
(haml
(:div.container
(form
the-form
; after successful submit
(λ (answer) (put 'comprehension-test answer))
; renderer: (-> rw xexpr)
(λ (rw)
(define n-tasks (number->string (get 'required-tasks)))
`(div
(p "The Study Instructions are repeated below.")
(div ((class "group"))
(label ((class "radio-group"))
"Suppose that after you complete the required tasks and make your choices, you end up with extra tasks. What happens if you fail the extra tasks -- either due to getting too many tasks wrong or not attempting them?"
,(rw "what-if-fail-study?"
(widget-radio-group '(("no-payment-at-all" . "You will receive no payment at all")
("no-extra-bonus" . "You will not receive the extra bonus payment, but you will receive the participation fee and the payment for the required tasks")
("no-extra-no-participation-fee" . "You will receive the payment for the required tasks, but not the participation fee nor the extra bonus, since you cannot complete the study.")))))
,@(rw "what-if-fail-study?" (widget-errors)))
(div ((class "group"))
(label ((class "radio-group"))
"How many required tasks do you have to do?"
,(rw "how-many-required-tasks?"
(widget-radio-group `(("0" . "0")
("6" . "6")
(,n-tasks . ,n-tasks)
("13" . "13")))))
,@(rw "how-many-required-tasks?" (widget-errors)))
(button ((type "Submit") (class "button")) "Submit")))))))
(formular
(haml
(:div
(:p "The Study Instructions are repeated below.")
(:: #:what-if-fail?
(radios
"Suppose that after you complete the required tasks and make your choices, you end up with extra tasks. What happens if you fail the extra tasks -- either due to getting too many tasks wrong or not attempting them?"
'(("no-payment-at-all" . "You will receive no payment at all")
("no-extra-bonus" . "You will not receive the extra bonus payment, but you will receive the participation fee and the payment for the required tasks")
("no-extra-no-participation-fee" . "You will receive the payment for the required tasks, but not the participation fee nor the extra bonus, since you cannot complete the study."))
#:validators
(list (is-equal "no-extra-no-participation-fee"
#:message "No. You receive payment for required tasks, but not for the participation fee."))))
(:: #:how-many-required-tasks?
(radios
"How many required tasks do you have to do?"
`(("0" . "0")
("6" . "6")
(,n-tasks . ,n-tasks)
("13" . "13"))
#:validators
(list (is-equal n-tasks #:message "No. Read the study description again."))))
(:button.button
([:type "submit"])
"Submit")))
(lambda (#:what-if-fail? what-if?
#:how-many-required-tasks? how-many?)
(put 'comprehension-test (list what-if? how-many?)))))))

(define (test-comprehension/bot)
(define f (bot:find "form"))
Expand Down Expand Up @@ -625,23 +614,17 @@

(define (tutorial-completion-consent)
(define (render-check-completion-code)
(define the-form
(form* ([check-completion-code-entered (ensure binding/boolean (required #:message "Before continuing, enter the completion code on prolific to ensure you finished the tutorial in time."))])
check-completion-code-entered))

(haml
(:div.container
(form
the-form
; after successful submit
(λ (answer) (put 'completion-code-entered answer))
; renderer: (-> rw xexpr)
(λ (rw)
`(div ((class "group"))
(label
,(rw "check-completion-code-entered" (widget-checkbox)) "I have entered the completion code on prolific")
,@(rw "check-completion-code-entered" (widget-errors))
(button ((type "Submit") (class "button")) "Continue to Study")))))))
(haml
(:div.container
(formular
(haml
(:div
(:: #:checked? (checkbox "I have entered the completion code on prolific"))
(:button.button
([:type "submit"])
"Continue to Study")))
(lambda (#:checked? checked?)
(put 'completion-code-entered checked?))))))

(define code (get 'completion-code))
(page
Expand Down

0 comments on commit f2916bd

Please sign in to comment.