devforms-0.1.2.0: src/Question.hs
{-# LANGUAGE QuasiQuotes #-}
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 = 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)
data QuestionOptions = QuestionOptions
{ lowerBoundInclusive :: Maybe Integer
, upperBoundInclusive :: Maybe Integer
}
deriving (Show)
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
renderQuestion :: Question -> Html ()
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_ [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
set my.value to my.value.replace('/[^0-9-]/g', '')
end
|]
, runJust
""
lowerBoundInclusive
( \lb ->
[__i|
on input
if my.value < #{lb} then set my.value to #{lb}
end
|]
)
, runJust
""
upperBoundInclusive
( \ub ->
[__i|
on input
if my.value > #{ub} then
set newValue to my.value
repeat while newValue > #{ub}
set newValue to parseInt(newValue.toString().substring(1))
end
set my.value to newValue
end
|]
)
]
let validationScript = Text.intercalate "\n" validationScriptParts
input_ $
catMaybes
[ Just $ type_ "number"
, 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
]
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"
, "Neither agree nor disagree"
, "Somewhat agree"
, "Strongly agree"
]
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_ [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{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)
isValidDate :: Text -> Bool
isValidDate t = case Text.splitOn "-" t of
[y, m, d] ->
Text.length y == 4
&& Text.length m == 2
&& Text.length d == 2
&& isJust (readMaybe (toString y) :: Maybe Int)
&& isJust (readMaybe (toString m) :: Maybe Int)
&& isJust (readMaybe (toString d) :: Maybe Int)
_ -> False
isValidTime :: Text -> Bool
isValidTime t = case Text.splitOn ":" t of
[h, m] ->
Text.length h == 2
&& Text.length m == 2
&& isJust (readMaybe (toString h) :: Maybe Int)
&& isJust (readMaybe (toString m) :: Maybe Int)
_ -> False