devforms 0.1.1.0 → 0.1.2.0
raw patch · 6 files changed
+155/−65 lines, 6 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- DevForms: questionText :: Text -> FormBuilder ()
+ DevForms: questionFreeText :: Text -> FormBuilder ()
Files
- devforms.cabal +1/−1
- examples/Example.hs +1/−1
- src/DevForms.hs +11/−11
- src/Form.hs +7/−3
- src/Question.hs +97/−49
- src/Server.hs +38/−0
devforms.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: devforms-version: 0.1.1.0+version: 0.1.2.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
examples/Example.hs view
@@ -26,4 +26,4 @@ setUpperBoundInclusive 15 questionLikert "This form works well" questionTime "Select a time"- questionText "Any special requests?"+ questionFreeText "Any special requests?"
src/DevForms.hs view
@@ -24,11 +24,11 @@ setUpperBoundInclusive 10 @ -}-module DevForms (ServerBuilder, FormBuilder, QuestionBuilder, devFormServer, form, questionCheckbox, questionLikert, questionChoice, questionDate, questionTime, questionInteger, setLowerBoundInclusive, setUpperBoundInclusive, questionText) where+module DevForms (ServerBuilder, FormBuilder, QuestionBuilder, devFormServer, form, questionCheckbox, questionLikert, questionChoice, questionDate, questionTime, questionInteger, setLowerBoundInclusive, setUpperBoundInclusive, questionFreeText) where import Control.Monad.Writer import Form (Form (..), FormBuilder)-import Question (Question (..), QuestionBuilder, QuestionOptions (..))+import Question (Question (..), QuestionBuilder, QuestionOptions (..), QuestionType (..)) import Server (Server (..), ServerBuilder, runServer) {- | Start the devforms web server on the given port.@@ -71,14 +71,14 @@ respondent can tick or leave unticked. -} questionCheckbox :: Text -> FormBuilder ()-questionCheckbox =- addQuestion . QuestionCheckbox+questionCheckbox questionText =+ addQuestion $ Question questionText QuestionCheckbox {- | Add a Likert-scale question. Renders as a 5-point agreement scale (Strongly disagree … Strongly agree) plus a \"Cannot say\" option. -} questionLikert :: Text -> FormBuilder ()-questionLikert = addQuestion . QuestionLikert+questionLikert questionText = addQuestion $ Question questionText QuestionLikert {- | Add a multiple-choice question. Renders as a group of radio buttons — the respondent must select exactly one of the provided options.@@ -87,19 +87,19 @@ -} questionChoice :: Text -> [Text] -> FormBuilder () questionChoice title qOptions =- addQuestion $ QuestionChoice title qOptions+ addQuestion $ Question title (QuestionChoice qOptions) {- | Add a date-picker question. Renders as an HTML date input and stores the answer in @YYYY-MM-DD@ format. -} questionDate :: Text -> FormBuilder ()-questionDate = addQuestion . QuestionDate+questionDate questionText = addQuestion $ Question questionText QuestionDate {- | Add a time-picker question. Renders as an HTML time input and stores the answer in @HH:MM@ format. -} questionTime :: Text -> FormBuilder ()-questionTime = addQuestion . QuestionTime+questionTime questionText = addQuestion $ Question questionText QuestionTime {- | Add an integer input question. The second argument is a 'QuestionBuilder' block where you can optionally configure bounds using@@ -117,7 +117,7 @@ questionInteger :: Text -> QuestionBuilder () -> FormBuilder () questionInteger title questionBuilder = do let questionOptions = appEndo (execWriter questionBuilder) $ QuestionOptions{lowerBoundInclusive = Nothing, upperBoundInclusive = Nothing}- addQuestion $ QuestionInteger title questionOptions+ addQuestion $ Question title (QuestionInteger questionOptions) -- | Set the minimum allowed value (inclusive) for a 'questionInteger'. setLowerBoundInclusive :: Integer -> QuestionBuilder ()@@ -127,5 +127,5 @@ setUpperBoundInclusive :: Integer -> QuestionBuilder () setUpperBoundInclusive bound = tell $ Endo $ \questionOptions -> questionOptions{upperBoundInclusive = Just bound} -questionText :: Text -> FormBuilder ()-questionText = addQuestion . QuestionText+questionFreeText :: Text -> FormBuilder ()+questionFreeText questionText = addQuestion $ Question questionText QuestionFreeText
src/Form.hs view
@@ -14,9 +14,13 @@ renderForm form@Form{title, questions} = do main_ $ do h2_ $ toHtml title- form_ [hxPost_ $ getSubmitUrl form, script_ "on keydown[key is 'Enter'] from <input/> halt"] $ do- forM_ (reverse questions) renderQuestion- input_ [type_ "submit"]+ validationEnhancer_ $+ form_ [hxPost_ $ getSubmitUrl form, script_ "on keydown[key is 'Enter'] from <input/> halt"] $ do+ forM_ (reverse questions) renderQuestion+ input_ [type_ "submit"]++validationEnhancer_ :: Html () -> Html ()+validationEnhancer_ = term "validation-enhancer" getFormUrl :: (IsString a) => Form -> a getFormUrl Form{formId} = fromString $ "/" <> toString formId
src/Question.hs view
@@ -1,18 +1,25 @@ {-# LANGUAGE QuasiQuotes #-} -module Question (Question (..), QuestionOptions (..), QuestionBuilder, renderQuestion, parseAnswers) where+module Question (Question (..), QuestionType (..), QuestionOptions (..), QuestionBuilder, 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 -data Question = QuestionCheckbox Text | QuestionLikert Text | QuestionChoice Text [Text] | QuestionDate Text | QuestionInteger Text QuestionOptions | QuestionTime Text | QuestionText Text deriving (Show)+data Question = Question+ { questionText :: Text+ , questionType :: QuestionType+ }+ 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) @@ -26,24 +33,50 @@ 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+ renderQuestion :: Question -> Html ()-renderQuestion question = do- section_ $ do- case question of- QuestionCheckbox questionText -> do- h3_ $ toHtml questionText- input_ [type_ "checkbox", name_ questionText]- QuestionChoice questionText choices -> do- h3_ $ toHtml questionText+renderQuestion Question{questionText, questionType} = do+ div_ [class_ "input"] $ do+ let qId = questionId questionText+ let errId = validationId questionText+ case questionType of+ QuestionChoice _ -> mempty+ QuestionLikert -> mempty+ _ -> label_ [Lucid.for_ qId] $ toHtml questionText+ case questionType of+ QuestionCheckbox -> do+ input_ [id_ qId, type_ "checkbox", name_ questionText]+ QuestionChoice choices -> do+ let radioScript =+ [__i|+ on change+ set radios to <input[name='#{qId}']/> in closest <fieldset/>+ for radio in radios+ remove .invalid from radio+ add .valid to radio+ end+ end+ |] ::+ Text fieldset_ $ do+ legend_ $ toHtml questionText forM_ choices $ \c -> do div_ $ do- input_ [type_ "radio", name_ questionText, value_ c, required_ ""]- label_ [Lucid.for_ questionText] $ toHtml c- QuestionDate questionText -> do- h3_ $ toHtml questionText- input_ [type_ "date", name_ questionText, required_ ""]- QuestionInteger questionText (QuestionOptions{lowerBoundInclusive, upperBoundInclusive}) -> do+ input_ [id_ (qId <> c), type_ "radio", name_ qId, value_ c, required_ "", ariaErrormessage_ errId, script_ radioScript]+ label_ [Lucid.for_ (qId <> c)] $ toHtml c+ QuestionDate -> do+ input_ [type_ "date", name_ questionText, required_ "", ariaErrormessage_ errId]+ QuestionInteger (QuestionOptions{lowerBoundInclusive, upperBoundInclusive}) -> do let validationScriptParts = [ [__i| on input@@ -51,20 +84,20 @@ end |] , runJust- ""- lowerBoundInclusive- ( \lb ->- [__i|+ ""+ lowerBoundInclusive+ ( \lb ->+ [__i| on input if my.value < #{lb} then set my.value to #{lb} end |]- )+ ) , runJust- ""- upperBoundInclusive- ( \ub ->- [__i|+ ""+ upperBoundInclusive+ ( \ub ->+ [__i| on input if my.value > #{ub} then@@ -76,11 +109,10 @@ set my.value to newValue end |]- )+ ) ] let validationScript = Text.intercalate "\n" validationScriptParts - h3_ $ toHtml questionText input_ $ catMaybes [ Just $ type_ "number"@@ -89,10 +121,23 @@ , Just $ pattern_ "[0-9]+" , Just $ required_ "" , Just $ script_ validationScript+ , Just $ ariaErrormessage_ errId+ , Just $ id_ "integer" , fmap (min_ . show) lowerBoundInclusive , fmap (max_ . show) upperBoundInclusive ]- QuestionLikert questionText -> do+ QuestionLikert -> do+ let radioScript =+ [__i|+ on change+ set radios to <input[name='#{qId}']/> in closest <fieldset/>+ for radio in radios+ remove .invalid from radio+ add .valid to radio+ end+ end+ |] ::+ Text let choices = [ "Strongly disagree" :: Text , "Somewhat disagree"@@ -100,41 +145,44 @@ , "Somewhat agree" , "Strongly agree" ]- h3_ $ toHtml questionText- forM_ choices $ \c -> do+ fieldset_ $ do+ legend_ $ toHtml questionText+ forM_ choices $ \c -> do+ div_ $ do+ input_ [id_ (qId <> c), type_ "radio", name_ qId, value_ c, required_ "", ariaErrormessage_ errId, script_ radioScript]+ label_ [Lucid.for_ (qId <> c)] $ toHtml c div_ $ do- input_ [type_ "radio", name_ questionText, value_ c, required_ ""]- toHtml c- div_ $ do- input_ [type_ "radio", name_ questionText, value_ "Cannot say", required_ ""]- "Cannot say"- QuestionTime questionText -> do- h3_ $ toHtml questionText- input_ [type_ "time", name_ questionText, required_ ""]- QuestionText questionText -> do- h3_ $ toHtml questionText- textarea_ [name_ questionText, required_ ""] ""+ input_ [id_ (qId <> "cannot-say"), type_ "radio", name_ qId, value_ "Cannot say", required_ "", script_ radioScript]+ label_ [Lucid.for_ (qId <> "cannot-say")] $ "Cannot say"+ QuestionTime -> do+ input_ [type_ "time", name_ questionText, required_ "", ariaErrormessage_ errId]+ QuestionFreeText -> do+ textarea_ [name_ questionText, required_ "", ariaErrormessage_ errId] ""+ div_ [id_ errId, class_ "validation-message"] mempty +ariaErrormessage_ :: Text -> Attributes+ariaErrormessage_ = term "aria-errormessage"+ 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 params = case question of- QuestionCheckbox questionText ->+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 questionText QuestionOptions{lowerBoundInclusive, upperBoundInclusive} -> do+ 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 questionText choices ->+ 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 questionText ->+ QuestionLikert -> let likertOptions = [ "Strongly disagree" , "Somewhat disagree"@@ -148,19 +196,19 @@ Just raw | raw `elem` likertOptions -> Right (Key.fromText questionText, JSON.toJSON raw) | otherwise -> Left $ "Invalid Likert option for: " <> questionText <> ". Got: " <> raw- QuestionDate questionText ->+ 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 questionText ->+ 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"- QuestionText questionText ->+ QuestionFreeText -> case lookup questionText params of Nothing -> Left $ "Missing required field: " <> questionText Just raw
src/Server.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} module Server (Server (..), ServerBuilder, runServer) where@@ -8,6 +9,7 @@ import Data.Aeson qualified as JSON import Data.FileEmbed (embedDir) import Data.Map qualified as Map+import Data.String.Interpolate import Data.Time (UTCTime, getCurrentTime) import Form (Form (..), getFormUrl, getSubmitUrl, renderForm) import Lucid@@ -34,6 +36,8 @@ asset <- Scotty.pathParam "asset" when (takeExtension asset == ".svg") $ do Scotty.addHeader "Content-Type" "image/svg+xml"+ when (takeExtension asset == ".js") $ do+ Scotty.addHeader "Content-Type" "application/javascript" case Map.lookup asset staticFiles of Just content -> Scotty.raw $ toLazy content Nothing -> Scotty.throw $ Scotty.QueryParameterNotFound $ toText asset@@ -89,9 +93,43 @@ ( do script_ [src_ "static/htmx.min.js"] ("" :: String) script_ [src_ "static/_hyperscript.min.js"] ("" :: String)+ script_ [type_ "module", src_ "static/validation-enhancer.min.js"] ("" :: String) link_ [rel_ "stylesheet", href_ "static/pico.classless.green.min.css"] link_ [rel_ "stylesheet", href_ "https://cdnjs.cloudflare.com/ajax/libs/font-awesome/6.4.0/css/all.min.css"]+ style_+ [__i|+ .valid {+ border-color: \#2e7d32;+ }++ .invalid {+ border-color: \#c62828;+ }++ .input {+ margin-bottom: 1.25rem;+ }++ .input input, .input fieldset {+ margin-bottom: 0rem;+ }++ .validation-message {+ font-size: 0.85rem;+ color: \#c62828;+ min-height: 1.25rem;+ margin-top: 0.2rem;+ }++ .input>label, fieldset>legend {+ display: block;+ font-weight: 600;+ margin-bottom: 0.25rem;+ }++ |] )+ body_ ( do main_