devforms 0.2.0.2 → 0.2.1.0

raw patch · 5 files changed

+180/−4 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• devforms.cabal +2/−1
• examples/Example.hs +11/−0
• src/DevForms.hs +45/−0
• src/Question.hs +121/−3
• static/validation-enhancer.min.js +1/−0

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               devforms-version:            0.2.0.2+version:            0.2.1.0 synopsis:           A builder DSL for HTML survey forms with built-in server and storage description:     devforms is a Haskell library for building HTML survey forms using a@@ -18,6 +18,7 @@ extra-source-files: static/_hyperscript.min.js     , static/htmx.min.js     , static/pico.classless.green.min.css+    , static/validation-enhancer.min.js  source-repository head     type:     git

@@ -13,6 +13,16 @@             , "Camel"             , "Duck"             ]+        questionMultiChoiceWith+            "Which animals have you seen?"+            [ "Alpaca"+            , "Bumblebee"+            , "Camel"+            , "Duck"+            ]+            $ do+                setMinSelections 1 :: MultiChoiceQuestionBuilder ()+                setMaxSelections 3         questionDateWith "On which day would you like to meet your favourite animal?" $ setOptional         questionTime "On which time would you like to have the meeting?"         questionIntegerWith "How many siblings do you have?" $ do@@ -21,6 +31,7 @@     form "Another simple form" "otherform" $ do         questionCheckbox "Do you want to check this box?"         questionChoice "Select one of the following:" ["A", "B", "C"]+        questionMultiChoice "Select all that apply:" ["X", "Y", "Z"]         questionDate "Select a date"         questionIntegerWith "Enter a natural number" $ do             setUpperBoundInclusive 15

@@ -24,6 +24,9 @@         questionLikert "I enjoy seeing animals"         questionChoice "Favourite animal"             ["Alpaca", "Bumblebee", "Camel", "Duck"]+        questionMultiChoiceWith "Which animals have you seen?" ["Alpaca", "Bumblebee", "Camel", "Duck"] $ do+            setMinSelections 1+            setMaxSelections 3         questionDateWith "When would you like to visit the zoo?" $ setOptional         questionIntegerWith "How many tickets?" $ do             setLowerBoundInclusive 1@@ -35,8 +38,10 @@     FormBuilder,     QuestionBuilder,     IntegerQuestionBuilder,+    MultiChoiceQuestionBuilder,     HasOptional (..),     HasBounds (..),+    HasSelectionBounds (..),     devFormServer,     form,     questionCheckbox,@@ -45,6 +50,8 @@     questionLikertWith,     questionChoice,     questionChoiceWith,+    questionMultiChoice,+    questionMultiChoiceWith,     questionDate,     questionDateWith,     questionTime,@@ -62,11 +69,14 @@ import Question (     HasBounds (..),     HasOptional (..),+    HasSelectionBounds (..),     IntegerQuestionBuilder,+    MultiChoiceQuestionBuilder,     Question (..),     QuestionBuilder,     QuestionType (..),     runIntegerQuestionBuilder,+    runMultiChoiceQuestionBuilder,     runQuestionBuilder,  ) import Server (Server (..), ServerBuilder, runServer)@@ -157,6 +167,41 @@ questionChoiceWith :: Text -> [Text] -> QuestionBuilder () -> FormBuilder () questionChoiceWith title qOptions builder =     addQuestion $ Question title (QuestionChoice qOptions) (runQuestionBuilder builder)++{- | Add a multiple-choice question with default options. Renders as a group of+checkboxes — the respondent can select one or more of the provided options.++The first argument is the question label; the second is the list of choices.+By default, at least one selection is required. Use 'questionMultiChoiceWith'+to configure selection bounds or mark as optional.+-}+questionMultiChoice :: Text -> [Text] -> FormBuilder ()+questionMultiChoice label options = questionMultiChoiceWith label options (pure ())++{- | Add a multiple-choice question with custom options. Renders as a group of+checkboxes — the respondent can select one or more of the provided options.++The first argument is the question label; the second is the list of choices.+The third argument is a 'MultiChoiceQuestionBuilder' block where you can+configure selection bounds using 'setMinSelections' and 'setMaxSelections',+as well as shared options like 'setOptional'.++Selection bounds are enforced both client-side (via _hyperscript) and+server-side on submission. If the question is optional, the respondent may+skip it entirely (zero selections), but if they select any options, the+min\/max constraints must be satisfied.++=== Example++@+questionMultiChoiceWith "Pick your toppings" ["Cheese", "Mushrooms", "Peppers", "Olives"] $ do+    setMinSelections 1+    setMaxSelections 3+@+-}+questionMultiChoiceWith :: Text -> [Text] -> MultiChoiceQuestionBuilder () -> FormBuilder ()+questionMultiChoiceWith title qOptions builder =+    addQuestion $ Question title (QuestionMultiChoice qOptions) (runMultiChoiceQuestionBuilder builder)  {- | Add a date-picker question with default options. Renders as an HTML date input and stores the answer in @YYYY-MM-DD@ format.

@@ -7,10 +7,13 @@     QuestionOptions (..),     QuestionBuilder,     IntegerQuestionBuilder,+    MultiChoiceQuestionBuilder,     HasOptional (..),     HasBounds (..),+    HasSelectionBounds (..),     runQuestionBuilder,     runIntegerQuestionBuilder,+    runMultiChoiceQuestionBuilder,     defaultOptions,     renderQuestion,     parseAnswers,@@ -33,17 +36,19 @@     }     deriving (Show) -data QuestionType = QuestionCheckbox | QuestionLikert | QuestionChoice [Text] | QuestionDate | QuestionInteger | QuestionTime | QuestionFreeText | QuestionRegexText Text deriving (Show)+data QuestionType = QuestionCheckbox | QuestionLikert | QuestionChoice [Text] | QuestionMultiChoice [Text] | QuestionDate | QuestionInteger | QuestionTime | QuestionFreeText | QuestionRegexText Text deriving (Show)  data QuestionOptions = QuestionOptions     { isOptional :: Bool     , lowerBoundInclusive :: Maybe Integer     , upperBoundInclusive :: Maybe Integer+    , minSelections :: Maybe Int+    , maxSelections :: Maybe Int     }     deriving (Show)  defaultOptions :: QuestionOptions-defaultOptions = QuestionOptions{isOptional = False, lowerBoundInclusive = Nothing, upperBoundInclusive = Nothing}+defaultOptions = QuestionOptions{isOptional = False, lowerBoundInclusive = Nothing, upperBoundInclusive = Nothing, minSelections = Nothing, maxSelections = Nothing}  -- | A builder monad for configuring shared question options (e.g. optionality). newtype QuestionBuilder a = QuestionBuilder (Writer (Endo QuestionOptions) a)@@ -53,6 +58,10 @@ newtype IntegerQuestionBuilder a = IntegerQuestionBuilder (Writer (Endo QuestionOptions) a)     deriving newtype (Functor, Applicative, Monad) +-- | A builder monad for configuring multi-choice question options (selection bounds and optionality).+newtype MultiChoiceQuestionBuilder a = MultiChoiceQuestionBuilder (Writer (Endo QuestionOptions) a)+    deriving newtype (Functor, Applicative, Monad)+ -- | Typeclass for builders that support marking a question as optional. class HasOptional m where     setOptional :: m@@ -62,6 +71,11 @@     setLowerBoundInclusive :: Integer -> m     setUpperBoundInclusive :: Integer -> m +-- | Typeclass for builders that support setting selection count bounds.+class HasSelectionBounds m where+    setMinSelections :: Int -> m+    setMaxSelections :: Int -> m+ instance HasOptional (QuestionBuilder ()) where     setOptional = QuestionBuilder $ tell $ Endo $ \o -> o{isOptional = True} @@ -72,8 +86,15 @@     setLowerBoundInclusive bound = IntegerQuestionBuilder $ tell $ Endo $ \o -> o{lowerBoundInclusive = Just bound}     setUpperBoundInclusive bound = IntegerQuestionBuilder $ tell $ Endo $ \o -> o{upperBoundInclusive = Just bound} -data AnswerError = NoRegexMatch Text | MissingRequiredField Text | InvalidTimeFormatFor Text | InvalidDateFormatFor Text | InvalidLikertOptionFor Text | InvalidChoiceFor Text | InvalidIntegerFor Text IntegerBoundError | IntegerParseErrorFor Text deriving (Show)+instance HasOptional (MultiChoiceQuestionBuilder ()) where+    setOptional = MultiChoiceQuestionBuilder $ tell $ Endo $ \o -> o{isOptional = True} +instance HasSelectionBounds (MultiChoiceQuestionBuilder ()) where+    setMinSelections n = MultiChoiceQuestionBuilder $ tell $ Endo $ \o -> o{minSelections = Just n}+    setMaxSelections n = MultiChoiceQuestionBuilder $ tell $ Endo $ \o -> o{maxSelections = Just n}++data AnswerError = NoRegexMatch Text | MissingRequiredField Text | InvalidTimeFormatFor Text | InvalidDateFormatFor Text | InvalidLikertOptionFor Text | InvalidChoiceFor Text | InvalidIntegerFor Text IntegerBoundError | IntegerParseErrorFor Text | InvalidSelectionCountFor Text deriving (Show)+ -- | Run a 'QuestionBuilder' to extract the configured 'QuestionOptions'. runQuestionBuilder :: QuestionBuilder () -> QuestionOptions runQuestionBuilder (QuestionBuilder w) = appEndo (execWriter w) defaultOptions@@ -82,6 +103,10 @@ runIntegerQuestionBuilder :: IntegerQuestionBuilder () -> QuestionOptions runIntegerQuestionBuilder (IntegerQuestionBuilder w) = appEndo (execWriter w) defaultOptions +-- | Run a 'MultiChoiceQuestionBuilder' to extract the configured 'QuestionOptions'.+runMultiChoiceQuestionBuilder :: MultiChoiceQuestionBuilder () -> QuestionOptions+runMultiChoiceQuestionBuilder (MultiChoiceQuestionBuilder w) = appEndo (execWriter w) defaultOptions+ runJust :: a -> Maybe b -> (b -> a) -> a runJust _ (Just x) f = f x runJust defaultValue Nothing _ = defaultValue@@ -101,6 +126,7 @@         let requiredAttrs = if isRequired then [required_ ""] else []         case questionType of             QuestionChoice _ -> mempty+            QuestionMultiChoice _ -> mempty             QuestionLikert -> mempty             _ -> label_ [Lucid.for_ qId] $ toHtml questionText         case questionType of@@ -124,6 +150,83 @@                         div_ $ do                             input_ $ [id_ (qId <> c), type_ "radio", name_ qId, value_ c, ariaErrormessage_ errId, script_ radioScript] <> requiredAttrs                             label_ [Lucid.for_ (qId <> c)] $ toHtml c+            QuestionMultiChoice choices -> do+                let QuestionOptions{minSelections = minSel, maxSelections = maxSel} = questionOptions+                let effectiveMin = fromMaybe (if isRequired then 1 else 0) minSel :: Int+                let effectiveMax = fromMaybe (length choices) maxSel :: Int+                let isOpt = isOptional questionOptions+                let optionalCheck = if isOpt then ("true" :: Text) else "false"+                let minText = show effectiveMin :: Text+                let maxText = show effectiveMax :: Text+                let proxyId = qId <> "-proxy"+                let validationMsg = "Please select between " <> minText <> " and " <> maxText <> " options"+                let checkboxScript =+                        [__i|+                      on change+                        set boxes to <input[type='checkbox']/> in closest <fieldset/>+                        set count to 0+                        for box in boxes+                          if box.checked increment count+                        end+                        set isValid to false+                        if #{optionalCheck} and count === 0+                          set isValid to true+                        else if count >= #{minText} and count <= #{maxText}+                          set isValid to true+                        end+                        if count > #{maxText}+                          set my.checked to false+                          halt+                        end+                        set proxy to document.getElementById('#{proxyId}')+                        if isValid+                          set proxy.value to 'valid'+                          js(proxy) proxy.setCustomValidity('') end+                          for box in boxes+                            js(box) box.setCustomValidity('') end+                            remove .invalid from box+                            add .valid to box+                          end+                        else+                          set proxy.value to ''+                          js(proxy) proxy.setCustomValidity('#{validationMsg}') end+                          for box in boxes+                            js(box) box.setCustomValidity('#{validationMsg}') end+                            remove .valid from box+                            add .invalid to box+                          end+                        end+                      end+                    |] ::+                            Text+                let proxyScript =+                        [__i|+                      on load+                        set boxes to <input[type='checkbox']/> in closest <fieldset/>+                        set msg to '#{validationMsg}'+                        if not #{optionalCheck}+                          for box in boxes+                            js(box, msg) box.setCustomValidity(msg) end+                          end+                        end+                      end+                    |] ::+                            Text+                fieldset_ $ do+                    legend_ $ toHtml questionText+                    input_ $+                        [ id_ proxyId+                        , type_ "text"+                        , style_ "display:none"+                        , tabindex_ "-1"+                        , ariaErrormessage_ errId+                        , script_ proxyScript+                        ]+                            <> requiredAttrs+                    forM_ choices $ \c -> do+                        div_ $ do+                            input_ [id_ (qId <> "-" <> c), type_ "checkbox", name_ (qId <> "-" <> c), ariaErrormessage_ errId, script_ checkboxScript]+                            label_ [Lucid.for_ (qId <> "-" <> c)] $ toHtml c             QuestionDate -> do                 input_ $ [type_ "date", name_ questionText, ariaErrormessage_ errId] <> requiredAttrs             QuestionInteger -> do@@ -262,6 +365,21 @@                     Just raw                         | raw `elem` choices -> Right (Key.fromText questionText, JSON.toJSON raw)                         | otherwise -> Left $ InvalidChoiceFor questionText+            QuestionMultiChoice choices ->+                let selected = filter (\c -> isJust $ Map.lookup (questionText <> "-" <> c) params') choices+                    count = length selected+                    QuestionOptions{minSelections = minSel, maxSelections = maxSel} = questionOptions+                    effectiveMin = fromMaybe (if isOptional questionOptions then 0 else 1) minSel+                    effectiveMax = fromMaybe (length choices) maxSel+                 in if count == 0 && isOptional questionOptions+                        then Right (Key.fromText questionText, JSON.Null)+                        else+                            if count == 0 && not (isOptional questionOptions)+                                then Left $ MissingRequiredField questionText+                                else+                                    if count < effectiveMin || count > effectiveMax+                                        then Left $ InvalidSelectionCountFor questionText+                                        else Right (Key.fromText questionText, JSON.toJSON selected)             QuestionLikert ->                 let likertOptions =                         [ "Strongly disagree"

@@ -0,0 +1,1 @@+class t extends HTMLElement{get validClass(){return this.getAttribute("valid-class")||"valid"}get invalidClass(){return this.getAttribute("invalid-class")||"invalid"}get messageTargetAttr(){return this.getAttribute("message-target-attr")||"aria-errormessage"}get messagePrefix(){return this.getAttribute("message-prefix")||"validation"}get messageAriaLive(){return this.getAttribute("message-aria-live")||"polite"}get scrollIntoViewOptions(){const t=this.getAttribute("scroll-align-to-top");if(null!==t)return"false"!==t;const e={behavior:this.getAttribute("scroll-behavior")||"smooth"},i=this.getAttribute("scroll-block");i&&(e.block=i);const s=this.getAttribute("scroll-inline");return s&&(e.inline=s),e}mutationObserver=null;constructor(){super(),this.handleChangeAndFocusOut=this.handleChangeAndFocusOut.bind(this),this.handleKeyUp=this.handleKeyUp.bind(this),this.handleSubmit=this.handleSubmit.bind(this),this.handleMutation=this.handleMutation.bind(this)}connectedCallback(){this.addEventListener("keyup",this.handleKeyUp),this.addEventListener("change",this.handleChangeAndFocusOut),this.addEventListener("focusout",this.handleChangeAndFocusOut),this.addEventListener("submit",this.handleSubmit);const t=this.querySelectorAll(`[${this.messageTargetAttr}]`);this.setupValidationTargetElements(Array.from(t));const e=this.querySelectorAll("form");this.setupForms(Array.from(e)),this.mutationObserver=new MutationObserver(this.handleMutation),this.mutationObserver.observe(this,{childList:!0,subtree:!0})}disconnectedCallback(){this.removeEventListener("keyup",this.handleKeyUp),this.removeEventListener("focusout",this.handleChangeAndFocusOut),this.removeEventListener("change",this.handleChangeAndFocusOut),this.removeEventListener("submit",this.handleSubmit),this.mutationObserver?.disconnect(),this.mutationObserver=null}handleMutation(t){t.forEach(t=>{const e=Array.from(t.addedNodes).filter(t=>t instanceof Element);this.setupValidationTargetElements(e);const i=e.filter(t=>t instanceof HTMLFormElement);this.setupForms(i)})}setupForms(t){t.forEach(t=>t.noValidate=!0)}ensureAriaLive(t){t.id&&this.querySelector(`[${this.messageTargetAttr}="${CSS.escape(t.id)}"]`)&&(t.hasAttribute("aria-live")||t.setAttribute("aria-live",this.messageAriaLive))}setupValidationTargetElements(t){t.forEach(t=>{const e=this.getValidationMessageTargetElement(t);e&&(e.hasAttribute("aria-live")||e.setAttribute("aria-live",this.messageAriaLive))})}handleKeyUp(t){const e=t.target;e&&this.validateInputPolitely(e)}handleChangeAndFocusOut(t){const e=t.target;this.isValidatableInput(e)&&this.validateInput(e)}handleSubmit(t){const e=t.target;if(!e)return;this.validateAllInputs(e)||(t.preventDefault(),t.stopPropagation())}validateInput(t){return!this.isValidatableInput(t)||(t.checkValidity()?(this.makeInputValid(t),!0):(this.makeInputInvalid(t),!1))}validateInputPolitely(t){return!this.isValidatableInput(t)||(t.checkValidity()?(this.makeInputValid(t),!0):(this.removeInputValidity(t),!1))}validateAllInputs(t){let e=!1;const i=this.getValidatableInputs(t);let s=!0;for(const t of i){if(!this.validateInput(t)&&(s=!1,!e)){e=!0;const i=this.getLabel(t)||t;this.scrollToElement(i),t.focus()}}return s}isValidatableInput(t){return!!t&&!(t instanceof HTMLButtonElement)&&"checkValidity"in t}makeInputValid(t){t.classList.add(this.validClass),t.classList.remove(this.invalidClass),t.removeAttribute("aria-invalid"),this.clearMessage(t)}makeInputInvalid(t){t.classList.add(this.invalidClass),t.classList.remove(this.validClass),t.setAttribute("aria-invalid","true"),this.showMessage(t)}removeInputValidity(t){t.classList.remove(this.validClass)}showMessage(t){const e=this.getCustomMessage(t)||t.validationMessage,i=this.getValidationMessageTargetElement(t);i&&(i.textContent=e)}clearMessage(t){const e=this.getValidationMessageTargetElement(t);e&&(e.textContent="")}getValidationMessageTargetElement(t){const e=t.getAttribute(this.messageTargetAttr);return e&&this.querySelector(`#${CSS.escape(e)}`)||null}validityKeys=["valueMissing","typeMismatch","patternMismatch","tooLong","tooShort","rangeUnderflow","rangeOverflow","stepMismatch","badInput"];getCustomMessage(t){if(!t.validity)return null;const e=this.messagePrefix;for(const i of this.validityKeys)if(i in t.validity&&t.validity[i])return t.getAttribute(`${e}-${i}`)??t.getAttribute(`data-${e}-${i}`);return null}getValidatableInputs(t){return Array.from(t.elements??[]).filter(this.isValidatableInput)}scrollToElement(t){const e=this.getAttribute("scroll-container");if(e){const i=document.querySelector(e);if(i){const e=i.getBoundingClientRect(),s=t.getBoundingClientRect(),a=this.scrollIntoViewOptions,n="boolean"==typeof a?"auto":a.behavior||"auto";return void i.scrollTo({top:i.scrollTop+(s.top-e.top),left:i.scrollLeft+(s.left-e.left),behavior:n})}}t.scrollIntoView(this.scrollIntoViewOptions)}getLabel(t){return t.id?document.querySelector(`label[for=${CSS.escape(t.id)}]`):null}}customElements.define("validation-enhancer",t);export{t as ValidationEnhancer};