devforms 0.1.2.0 → 0.2.0.1

raw patch · 6 files changed

+356/−126 lines, 6 filesdep +regex-basedep +regex-tdfaPVP ok

version bump matches the API change (PVP)

Dependencies added: regex-base, regex-tdfa

API changes (from Hackage documentation)

Files

• devforms.cabal +3/−1
• examples/Example.hs +5/−4
• src/DevForms.hs +168/−42
• src/ParsedInteger.hs +7/−5
• src/Question.hs +166/−74
• src/Server.hs +7/−0

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               devforms-version:            0.1.2.0+version:            0.2.0.1 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@@ -53,6 +53,8 @@         , string-interpolate   >= 0.3   && < 0.4         , file-embed           >= 0.0.15 && < 0.1         , containers           >= 0.6   && < 0.9+        , regex-base >= 0.94 && < 0.95+        , regex-tdfa >= 1.3 && < 1.4     hs-source-dirs:   src     default-language: GHC2021     mixins: base hiding (Prelude)

@@ -13,17 +13,18 @@             , "Camel"             , "Duck"             ]-        questionDate "On which day would you like to meet your favourite animal?"+        questionDateWith "On which day would you like to meet your favourite animal?" $ setOptional         questionTime "On which time would you like to have the meeting?"-        questionInteger "How many siblings do you have?" $ do+        questionIntegerWith "How many siblings do you have?" $ do             setLowerBoundInclusive 0      form "Another simple form" "otherform" $ do         questionCheckbox "Do you want to check this box?"         questionChoice "Select one of the following:" ["A", "B", "C"]         questionDate "Select a date"-        questionInteger "Enter a natural number" $ do+        questionIntegerWith "Enter a natural number" $ do             setUpperBoundInclusive 15         questionLikert "This form works well"         questionTime "Select a time"-        questionFreeText "Any special requests?"+        questionFreeTextWith "Any special requests?" $ setOptional+        questionRegexText "Enter five uppercase letters" "[A-Z]{5}"

@@ -9,6 +9,12 @@ builder DSL. Forms are served via a built-in web server (Scotty), and submissions are stored as JSONL files. +Each question type comes in two variants:++* A plain version (e.g. 'questionLikert') that uses default options.+* A @With@ version (e.g. 'questionLikertWith') that accepts a builder block+  for configuring options like 'setOptional' or bounds.+ === Example  @@@ -18,17 +24,51 @@         questionLikert "I enjoy seeing animals"         questionChoice "Favourite animal"             ["Alpaca", "Bumblebee", "Camel", "Duck"]-        questionDate "When would you like to visit the zoo?"-        questionInteger "How many tickets?" $ do+        questionDateWith "When would you like to visit the zoo?" $ setOptional+        questionIntegerWith "How many tickets?" $ do             setLowerBoundInclusive 1             setUpperBoundInclusive 10 @ -}-module DevForms (ServerBuilder, FormBuilder, QuestionBuilder, devFormServer, form, questionCheckbox, questionLikert, questionChoice, questionDate, questionTime, questionInteger, setLowerBoundInclusive, setUpperBoundInclusive, questionFreeText) where+module DevForms (+    ServerBuilder,+    FormBuilder,+    QuestionBuilder,+    IntegerQuestionBuilder,+    HasOptional (..),+    HasBounds (..),+    devFormServer,+    form,+    questionCheckbox,+    questionCheckboxWith,+    questionLikert,+    questionLikertWith,+    questionChoice,+    questionChoiceWith,+    questionDate,+    questionDateWith,+    questionTime,+    questionTimeWith,+    questionInteger,+    questionIntegerWith,+    questionFreeText,+    questionFreeTextWith,+    questionRegexText,+    questionRegexTextWith,+) where  import Control.Monad.Writer import Form (Form (..), FormBuilder)-import Question (Question (..), QuestionBuilder, QuestionOptions (..), QuestionType (..))+import Question (+    HasBounds (..),+    HasOptional (..),+    IntegerQuestionBuilder,+    Question (..),+    QuestionBuilder,+    QuestionType (..),+    runIntegerQuestionBuilder,+    runQuestionBuilder,+ ) import Server (Server (..), ServerBuilder, runServer)  {- | Start the devforms web server on the given port.@@ -43,10 +83,6 @@ devFormServer :: Int -> ServerBuilder () -> IO () devFormServer = runServer --- devFormServer serverBuilder = do---     let forms = appEndo (execWriter serverBuilder) $ Server{forms = []}---     print $ forms- {- | Define a survey form.  The first argument is the human-readable title displayed at the top of the@@ -67,65 +103,155 @@ addQuestion question =     tell $ Endo $ \f@Form{questions} -> f{questions = questions <> [question]} -{- | Add a yes\/no checkbox question. Renders as a single checkbox that the-respondent can tick or leave unticked.+{- | Add a yes\/no checkbox question with default options. Renders as a single+checkbox that the respondent can tick or leave unticked. -} questionCheckbox :: Text -> FormBuilder ()-questionCheckbox questionText =-    addQuestion $ Question questionText QuestionCheckbox+questionCheckbox label = questionCheckboxWith label (pure ()) -{- | Add a Likert-scale question. Renders as a 5-point agreement scale-(Strongly disagree … Strongly agree) plus a \"Cannot say\" option.+{- | Add a yes\/no checkbox question with custom options. Renders as a single+checkbox that the respondent can tick or leave unticked.++The second argument is a 'QuestionBuilder' block where you can configure+shared options such as 'setOptional'. -}+questionCheckboxWith :: Text -> QuestionBuilder () -> FormBuilder ()+questionCheckboxWith questionText builder =+    addQuestion $ Question questionText QuestionCheckbox (runQuestionBuilder builder)++{- | Add a Likert-scale question with default options. Renders as a 5-point+agreement scale (Strongly disagree … Strongly agree) plus a \"Cannot say\"+option.+-} questionLikert :: Text -> FormBuilder ()-questionLikert questionText = addQuestion $ Question questionText QuestionLikert+questionLikert label = questionLikertWith label (pure ()) -{- | Add a multiple-choice question. Renders as a group of radio buttons — the-respondent must select exactly one of the provided options.+{- | Add a Likert-scale question with custom options. Renders as a 5-point+agreement scale (Strongly disagree … Strongly agree) plus a \"Cannot say\"+option. +The second argument is a 'QuestionBuilder' block where you can configure+shared options such as 'setOptional'.+-}+questionLikertWith :: Text -> QuestionBuilder () -> FormBuilder ()+questionLikertWith questionText builder =+    addQuestion $ Question questionText QuestionLikert (runQuestionBuilder builder)++{- | Add a multiple-choice question with default options. Renders as a group of+radio buttons — the respondent must select exactly one of the provided+options.+ The first argument is the question label; the second is the list of choices. -} questionChoice :: Text -> [Text] -> FormBuilder ()-questionChoice title qOptions =-    addQuestion $ Question title (QuestionChoice qOptions)+questionChoice label options = questionChoiceWith label options (pure ()) -{- | Add a date-picker question. Renders as an HTML date input and stores the-answer in @YYYY-MM-DD@ format.+{- | Add a multiple-choice question with custom options. Renders as a group of+radio buttons — the respondent must select exactly one of the provided+options.++The first argument is the question label; the second is the list of choices.+The third argument is a 'QuestionBuilder' block where you can configure+shared options such as 'setOptional'. -}+questionChoiceWith :: Text -> [Text] -> QuestionBuilder () -> FormBuilder ()+questionChoiceWith title qOptions builder =+    addQuestion $ Question title (QuestionChoice qOptions) (runQuestionBuilder builder)++{- | Add a date-picker question with default options. Renders as an HTML date+input and stores the answer in @YYYY-MM-DD@ format.+-} questionDate :: Text -> FormBuilder ()-questionDate questionText = addQuestion $ Question questionText QuestionDate+questionDate label = questionDateWith label (pure ()) -{- | Add a time-picker question. Renders as an HTML time input and stores the-answer in @HH:MM@ format.+{- | Add a date-picker question with custom options. Renders as an HTML date+input and stores the answer in @YYYY-MM-DD@ format.++The second argument is a 'QuestionBuilder' block where you can configure+shared options such as 'setOptional'. -}+questionDateWith :: Text -> QuestionBuilder () -> FormBuilder ()+questionDateWith questionText builder =+    addQuestion $ Question questionText QuestionDate (runQuestionBuilder builder)++{- | Add a time-picker question with default options. Renders as an HTML time+input and stores the answer in @HH:MM@ format.+-} questionTime :: Text -> FormBuilder ()-questionTime questionText = addQuestion $ Question questionText QuestionTime+questionTime label = questionTimeWith label (pure ()) -{- | Add an integer input question. The second argument is a 'QuestionBuilder'-block where you can optionally configure bounds using-'setLowerBoundInclusive' and 'setUpperBoundInclusive'. Bounds are enforced-both client-side (via HTML attributes) and server-side on submission.+{- | Add a time-picker question with custom options. Renders as an HTML time+input and stores the answer in @HH:MM@ format. +The second argument is a 'QuestionBuilder' block where you can configure+shared options such as 'setOptional'.+-}+questionTimeWith :: Text -> QuestionBuilder () -> FormBuilder ()+questionTimeWith questionText builder =+    addQuestion $ Question questionText QuestionTime (runQuestionBuilder builder)++-- | Add an integer input question with default options (no bounds).+questionInteger :: Text -> FormBuilder ()+questionInteger label = questionIntegerWith label (pure ())++{- | Add an integer input question with custom options. The second argument is+an 'IntegerQuestionBuilder' block where you can configure bounds using+'setLowerBoundInclusive' and 'setUpperBoundInclusive', as well as shared+options like 'setOptional'. Bounds are enforced both client-side (via HTML+attributes) and server-side on submission.+ === Example  @-questionInteger "How many pets do you have?" $ do+questionIntegerWith "How many pets do you have?" $ do     setLowerBoundInclusive 0     setUpperBoundInclusive 50+    setOptional @ -}-questionInteger :: Text -> QuestionBuilder () -> FormBuilder ()-questionInteger title questionBuilder = do-    let questionOptions = appEndo (execWriter questionBuilder) $ QuestionOptions{lowerBoundInclusive = Nothing, upperBoundInclusive = Nothing}-    addQuestion $ Question title (QuestionInteger questionOptions)+questionIntegerWith :: Text -> IntegerQuestionBuilder () -> FormBuilder ()+questionIntegerWith title builder =+    addQuestion $ Question title QuestionInteger (runIntegerQuestionBuilder builder) --- | Set the minimum allowed value (inclusive) for a 'questionInteger'.-setLowerBoundInclusive :: Integer -> QuestionBuilder ()-setLowerBoundInclusive bound = tell $ Endo $ \questionOptions -> questionOptions{lowerBoundInclusive = Just bound}+{- | Add a free-text textarea question with default options. The respondent can+enter arbitrary text.+-}+questionFreeText :: Text -> FormBuilder ()+questionFreeText label = questionFreeTextWith label (pure ()) --- | Set the maximum allowed value (inclusive) for a 'questionInteger'.-setUpperBoundInclusive :: Integer -> QuestionBuilder ()-setUpperBoundInclusive bound = tell $ Endo $ \questionOptions -> questionOptions{upperBoundInclusive = Just bound}+{- | Add a free-text textarea question with custom options. The respondent can+enter arbitrary text. -questionFreeText :: Text -> FormBuilder ()-questionFreeText questionText = addQuestion $ Question questionText QuestionFreeText+The second argument is a 'QuestionBuilder' block where you can configure+shared options such as 'setOptional'.+-}+questionFreeTextWith :: Text -> QuestionBuilder () -> FormBuilder ()+questionFreeTextWith questionText builder =+    addQuestion $ Question questionText QuestionFreeText (runQuestionBuilder builder)++{- | Add a regex-validated text input question with default options. The+respondent's answer must match the given POSIX extended regex pattern.++The first argument is the question label; the second is the regex pattern.+-}+questionRegexText :: Text -> Text -> FormBuilder ()+questionRegexText label regexPattern = questionRegexTextWith label regexPattern (pure ())++{- | Add a regex-validated text input question with custom options. The+respondent's answer must match the given POSIX extended regex pattern. The+pattern is also set as the HTML @pattern@ attribute for client-side+validation.++The first argument is the question label; the second is the regex pattern.+The third argument is a 'QuestionBuilder' block where you can configure+shared options such as 'setOptional'.++=== Example++@+questionRegexTextWith "SemVer number" "^v\\d+.\\d+.\\d+$" $ setOptional+@+-}+questionRegexTextWith :: Text -> Text -> QuestionBuilder () -> FormBuilder ()+questionRegexTextWith questionText regexPattern builder =+    addQuestion $ Question questionText (QuestionRegexText regexPattern) (runQuestionBuilder builder)

@@ -1,21 +1,23 @@-module ParsedInteger (ParsedInteger, parseWithBounds, parsedToInteger)+module ParsedInteger (ParsedInteger, parseWithBounds, parsedToInteger, IntegerBoundError (..)) where  newtype ParsedInteger = ParsedInteger Integer -parseWithBounds :: Maybe Integer -> Maybe Integer -> Integer -> Either Text ParsedInteger+data IntegerBoundError = IntegerOutOfBounds deriving (Show)++parseWithBounds :: Maybe Integer -> Maybe Integer -> Integer -> Either IntegerBoundError ParsedInteger parseWithBounds (Just lowerBoundInclusive) (Just upperBoundInclusive) n =     if lowerBoundInclusive <= n && upperBoundInclusive >= n         then pure $ ParsedInteger n-        else Left "Integer is outside bounds"+        else Left IntegerOutOfBounds parseWithBounds (Just lowerBoundInclusive) Nothing n =     if lowerBoundInclusive <= n         then pure $ ParsedInteger n-        else Left "Integer is out of bounds"+        else Left IntegerOutOfBounds parseWithBounds Nothing (Just upperBoundInclusive) n =     if upperBoundInclusive >= n         then pure $ ParsedInteger n-        else Left "Integer is out of bounds"+        else Left IntegerOutOfBounds parseWithBounds Nothing Nothing n = Right $ ParsedInteger n  parsedToInteger :: ParsedInteger -> Integer

@@ -1,54 +1,104 @@+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE QuasiQuotes #-} -module Question (Question (..), QuestionType (..), QuestionOptions (..), QuestionBuilder, renderQuestion, parseAnswers) where+module Question (+    Question (..),+    QuestionType (..),+    QuestionOptions (..),+    QuestionBuilder,+    IntegerQuestionBuilder,+    HasOptional (..),+    HasBounds (..),+    runQuestionBuilder,+    runIntegerQuestionBuilder,+    defaultOptions,+    renderQuestion,+    parseAnswers,+) where  import Control.Monad.Writer import Data.Aeson qualified as JSON import Data.Aeson.Key qualified as Key-import Data.Char (isAlphaNum) import Data.String.Interpolate import Data.Text qualified as Text import Lucid import ParsedInteger import Relude.Extra.Map as Map+import Text.Regex.TDFA ((=~))  data Question = Question     { questionText :: Text     , questionType :: QuestionType+    , questionOptions :: QuestionOptions     }     deriving (Show) -data QuestionType = QuestionCheckbox | QuestionLikert | QuestionChoice [Text] | QuestionDate | QuestionInteger QuestionOptions | QuestionTime | QuestionFreeText deriving (Show)---- | A builder monad for configuring question options (e.g. bounds for integer questions).-type QuestionBuilder = Writer (Endo QuestionOptions)+data QuestionType = QuestionCheckbox | QuestionLikert | QuestionChoice [Text] | QuestionDate | QuestionInteger | QuestionTime | QuestionFreeText | QuestionRegexText Text deriving (Show)  data QuestionOptions = QuestionOptions-    { lowerBoundInclusive :: Maybe Integer+    { isOptional :: Bool+    , lowerBoundInclusive :: Maybe Integer     , upperBoundInclusive :: Maybe Integer     }     deriving (Show) +defaultOptions :: QuestionOptions+defaultOptions = QuestionOptions{isOptional = False, lowerBoundInclusive = Nothing, upperBoundInclusive = Nothing}++-- | A builder monad for configuring shared question options (e.g. optionality).+newtype QuestionBuilder a = QuestionBuilder (Writer (Endo QuestionOptions) a)+    deriving newtype (Functor, Applicative, Monad)++-- | A builder monad for configuring integer question options (bounds and optionality).+newtype IntegerQuestionBuilder a = IntegerQuestionBuilder (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++-- | Typeclass for builders that support setting numeric bounds.+class HasBounds m where+    setLowerBoundInclusive :: Integer -> m+    setUpperBoundInclusive :: Integer -> m++instance HasOptional (QuestionBuilder ()) where+    setOptional = QuestionBuilder $ tell $ Endo $ \o -> o{isOptional = True}++instance HasOptional (IntegerQuestionBuilder ()) where+    setOptional = IntegerQuestionBuilder $ tell $ Endo $ \o -> o{isOptional = True}++instance HasBounds (IntegerQuestionBuilder ()) where+    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)++-- | Run a 'QuestionBuilder' to extract the configured 'QuestionOptions'.+runQuestionBuilder :: QuestionBuilder () -> QuestionOptions+runQuestionBuilder (QuestionBuilder w) = appEndo (execWriter w) defaultOptions++-- | Run an 'IntegerQuestionBuilder' to extract the configured 'QuestionOptions'.+runIntegerQuestionBuilder :: IntegerQuestionBuilder () -> QuestionOptions+runIntegerQuestionBuilder (IntegerQuestionBuilder w) = appEndo (execWriter w) defaultOptions+ runJust :: a -> Maybe b -> (b -> a) -> a runJust _ (Just x) f = f x runJust defaultValue Nothing _ = defaultValue -questionId :: Text -> Text-questionId questionText = Text.intercalate "-" (Text.words slug)-  where-    slug = Text.toLower $ Text.map (\c -> if isAlphaNum c || c == ' ' then c else ' ') questionText- {- | Generate a unique validation tooltip ID from question text. E.g. "How old are you?" -> "err-how-old-are-you" -} validationId :: Text -> Text-validationId questionText = "err-" <> questionId questionText+validationId questionText = "err " <> questionText  renderQuestion :: Question -> Html ()-renderQuestion Question{questionText, questionType} = do+renderQuestion Question{questionText, questionType, questionOptions} = do     div_ [class_ "input"] $ do-        let qId = questionId questionText+        let qId = questionText         let errId = validationId questionText+        let isRequired = not (isOptional questionOptions)+        let requiredAttrs = if isRequired then [required_ ""] else []         case questionType of             QuestionChoice _ -> mempty             QuestionLikert -> mempty@@ -72,11 +122,12 @@                     legend_ $ toHtml questionText                     forM_ choices $ \c -> do                         div_ $ do-                            input_ [id_ (qId <> c), type_ "radio", name_ qId, value_ c, required_ "", ariaErrormessage_ errId, script_ radioScript]+                            input_ $ [id_ (qId <> c), type_ "radio", name_ qId, value_ c, ariaErrormessage_ errId, script_ radioScript] <> requiredAttrs                             label_ [Lucid.for_ (qId <> c)] $ toHtml c             QuestionDate -> do-                input_ [type_ "date", name_ questionText, required_ "", ariaErrormessage_ errId]-            QuestionInteger (QuestionOptions{lowerBoundInclusive, upperBoundInclusive}) -> do+                input_ $ [type_ "date", name_ questionText, ariaErrormessage_ errId] <> requiredAttrs+            QuestionInteger -> do+                let QuestionOptions{lowerBoundInclusive = lowerBound, upperBoundInclusive = upperBound} = questionOptions                 let validationScriptParts =                         [ [__i|                           on input@@ -85,7 +136,7 @@                         |]                         , runJust                             ""-                            lowerBoundInclusive+                            lowerBound                             ( \lb ->                                 [__i|                             on input@@ -95,7 +146,7 @@                             )                         , runJust                             ""-                            upperBoundInclusive+                            upperBound                             ( \ub ->                                 [__i| @@ -119,13 +170,13 @@                         , Just $ name_ questionText                         , Just $ step_ "1"                         , Just $ pattern_ "[0-9]+"-                        , Just $ required_ ""                         , Just $ script_ validationScript                         , Just $ ariaErrormessage_ errId                         , Just $ id_ "integer"-                        , fmap (min_ . show) lowerBoundInclusive-                        , fmap (max_ . show) upperBoundInclusive+                        , fmap (min_ . show) lowerBound+                        , fmap (max_ . show) upperBound                         ]+                        <> requiredAttrs             QuestionLikert -> do                 let radioScript =                         [__i|@@ -149,71 +200,112 @@                     legend_ $ toHtml questionText                     forM_ choices $ \c -> do                         div_ $ do-                            input_ [id_ (qId <> c), type_ "radio", name_ qId, value_ c, required_ "", ariaErrormessage_ errId, script_ radioScript]+                            input_ $ [id_ (qId <> c), type_ "radio", name_ qId, value_ c, ariaErrormessage_ errId, script_ radioScript] <> requiredAttrs                             label_ [Lucid.for_ (qId <> c)] $ toHtml c                     div_ $ do-                        input_ [id_ (qId <> "cannot-say"), type_ "radio", name_ qId, value_ "Cannot say", required_ "", script_ radioScript]+                        input_ $ [id_ (qId <> "cannot-say"), type_ "radio", name_ qId, value_ "Cannot say", script_ radioScript] <> requiredAttrs                         label_ [Lucid.for_ (qId <> "cannot-say")] $ "Cannot say"             QuestionTime -> do-                input_ [type_ "time", name_ questionText, required_ "", ariaErrormessage_ errId]+                input_ $ [type_ "time", name_ questionText, ariaErrormessage_ errId] <> requiredAttrs             QuestionFreeText -> do-                textarea_ [name_ questionText, required_ "", ariaErrormessage_ errId] ""+                textarea_ ([name_ questionText, ariaErrormessage_ errId] <> requiredAttrs) ""+            QuestionRegexText regexPattern -> do+                input_ $ [type_ "text", pattern_ regexPattern, name_ questionText, ariaErrormessage_ errId] <> requiredAttrs+        when (isOptional questionOptions) $+            div_ [class_ "hint"] "Optional"         div_ [id_ errId, class_ "validation-message"] mempty  ariaErrormessage_ :: Text -> Attributes ariaErrormessage_ = term "aria-errormessage" +mapLeft :: (a -> c) -> Either a b -> Either c b+mapLeft f (Left e) = Left (f e)+mapLeft _ (Right v) = (Right v)+ parseAnswers :: [Question] -> Map Text Text -> Either Text [(JSON.Key, JSON.Value)] parseAnswers questions params = mapM (`parseAnswer` params) questions  parseAnswer :: Question -> Map Text Text -> Either Text (JSON.Key, JSON.Value)-parseAnswer Question{questionText, questionType} params = case questionType of-    QuestionCheckbox ->-        let value = JSON.Bool $ isJust $ Map.lookup questionText params-         in Right (Key.fromText questionText, value)-    QuestionInteger QuestionOptions{lowerBoundInclusive, upperBoundInclusive} -> do-        answerRaw <- maybeToRight ("Missing required field: " <> questionText) $ Map.lookup questionText params-        n <- maybeToRight ("Invalid integer for: " <> questionText) (readMaybe (toString answerRaw) :: Maybe Integer)-        boundsCheckedInt <- parseWithBounds lowerBoundInclusive upperBoundInclusive n-        pure (Key.fromText questionText, JSON.toJSON (parsedToInteger boundsCheckedInt))-    QuestionChoice choices ->-        case Map.lookup questionText params of-            Nothing -> Left $ "Missing required field: " <> questionText-            Just raw-                | raw `elem` choices -> Right (Key.fromText questionText, JSON.toJSON raw)-                | otherwise -> Left $ "Invalid choice for: " <> questionText <> ". Got: " <> raw-    QuestionLikert ->-        let likertOptions =-                [ "Strongly disagree"-                , "Somewhat disagree"-                , "Neither agree nor disagree"-                , "Somewhat agree"-                , "Strongly agree"-                , "Cannot say"-                ]-         in case lookup questionText params of-                Nothing -> Left $ "Missing required field: " <> questionText-                Just raw-                    | raw `elem` likertOptions -> Right (Key.fromText questionText, JSON.toJSON raw)-                    | otherwise -> Left $ "Invalid Likert option for: " <> questionText <> ". Got: " <> raw-    QuestionDate ->-        case lookup questionText params of-            Nothing -> Left $ "Missing required field: " <> questionText-            Just raw-                | isValidDate raw -> Right (Key.fromText questionText, JSON.toJSON raw)-                | otherwise -> Left $ "Invalid date format for: " <> questionText <> ". Expected YYYY-MM-DD"-    QuestionTime ->-        case lookup questionText params of-            Nothing -> Left $ "Missing required field: " <> questionText-            Just raw-                | isValidTime raw -> Right (Key.fromText questionText, JSON.toJSON raw)-                | otherwise -> Left $ "Invalid time format for: " <> questionText <> ". Expected HH:MM"-    QuestionFreeText ->-        case lookup questionText params of-            Nothing -> Left $ "Missing required field: " <> questionText-            Just raw-                | Text.null (Text.strip raw) -> Left $ "Missing required field: " <> questionText-                | otherwise -> Right (Key.fromText questionText, JSON.toJSON raw)+parseAnswer Question{questionText, questionType, questionOptions} params =+    case result of+        Left e -> Left $ show e+        Right parsed -> Right parsed+  where+    -- Normalize: treat empty/whitespace-only values as missing for optional fields+    params'+        | isOptional questionOptions =+            case Map.lookup questionText params of+                Just v | Text.null (Text.strip v) -> Map.delete questionText params+                _ -> params+        | otherwise = params++    result =+        case questionType of+            QuestionCheckbox ->+                let value = JSON.Bool $ isJust $ Map.lookup questionText params'+                 in Right (Key.fromText questionText, value)+            QuestionInteger -> do+                let QuestionOptions{lowerBoundInclusive = lowerBound, upperBoundInclusive = upperBound} = questionOptions+                case Map.lookup questionText params' of+                    Nothing+                        | isOptional questionOptions -> Right (Key.fromText questionText, JSON.Null)+                        | otherwise -> Left $ MissingRequiredField questionText+                    Just raw -> do+                        n <- maybeToRight (IntegerParseErrorFor questionText) (readMaybe (toString raw) :: Maybe Integer)+                        boundsCheckedInt <- mapLeft (InvalidIntegerFor questionText) $ parseWithBounds lowerBound upperBound n+                        pure (Key.fromText questionText, JSON.toJSON (parsedToInteger boundsCheckedInt))+            QuestionChoice choices ->+                case Map.lookup questionText params' of+                    Nothing+                        | isOptional questionOptions -> Right (Key.fromText questionText, JSON.Null)+                        | otherwise -> Left $ MissingRequiredField questionText+                    Just raw+                        | raw `elem` choices -> Right (Key.fromText questionText, JSON.toJSON raw)+                        | otherwise -> Left $ InvalidChoiceFor questionText+            QuestionLikert ->+                let likertOptions =+                        [ "Strongly disagree"+                        , "Somewhat disagree"+                        , "Neither agree nor disagree"+                        , "Somewhat agree"+                        , "Strongly agree"+                        , "Cannot say"+                        ]+                 in case Map.lookup questionText params' of+                        Nothing+                            | isOptional questionOptions -> Right (Key.fromText questionText, JSON.Null)+                            | otherwise -> Left $ MissingRequiredField questionText+                        Just raw+                            | raw `elem` likertOptions -> Right (Key.fromText questionText, JSON.toJSON raw)+                            | otherwise -> Left $ InvalidLikertOptionFor questionText+            QuestionDate ->+                case Map.lookup questionText params' of+                    Nothing+                        | isOptional questionOptions -> Right (Key.fromText questionText, JSON.Null)+                        | otherwise -> Left $ MissingRequiredField questionText+                    Just raw+                        | isValidDate raw -> Right (Key.fromText questionText, JSON.toJSON raw)+                        | otherwise -> Left $ InvalidDateFormatFor questionText+            QuestionTime ->+                case Map.lookup questionText params' of+                    Nothing+                        | isOptional questionOptions -> Right (Key.fromText questionText, JSON.Null)+                        | otherwise -> Left $ MissingRequiredField questionText+                    Just raw+                        | isValidTime raw -> Right (Key.fromText questionText, JSON.toJSON raw)+                        | otherwise -> Left $ InvalidTimeFormatFor questionText+            QuestionFreeText ->+                case Map.lookup questionText params' of+                    Nothing+                        | isOptional questionOptions -> Right (Key.fromText questionText, JSON.Null)+                        | otherwise -> Left $ MissingRequiredField questionText+                    Just raw+                        | Text.null (Text.strip raw) -> Left $ MissingRequiredField questionText+                        | otherwise -> Right (Key.fromText questionText, JSON.toJSON raw)+            QuestionRegexText regex -> do+                case Map.lookup questionText params' of+                    Nothing -> if isOptional questionOptions then Right (Key.fromText questionText, JSON.Null) else Left (MissingRequiredField questionText)+                    Just answer -> if answer =~ ("^" <> regex <> "$") then pure (Key.fromText questionText, JSON.toJSON answer) else Left (NoRegexMatch questionText)  isValidDate :: Text -> Bool isValidDate t = case Text.splitOn "-" t of

@@ -121,6 +121,13 @@                         margin-top: 0.2rem;                       } +                      .hint {+                        font-size: 0.8rem;+                        font-weight: 400;+                        color: \#666;+                        margin-bottom: 0.25rem;+                      }+                       .input>label, fieldset>legend {                         display: block;                         font-weight: 600;