devforms-0.2.0.1: src/Question.hs

{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE QuasiQuotes #-}

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.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 | QuestionTime | QuestionFreeText | QuestionRegexText Text deriving (Show)

data QuestionOptions = QuestionOptions
    { 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

{- | 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 " <> questionText

renderQuestion :: Question -> Html ()
renderQuestion Question{questionText, questionType, questionOptions} = do
    div_ [class_ "input"] $ do
        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
            _ -> 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, ariaErrormessage_ errId, script_ radioScript] <> requiredAttrs
                            label_ [Lucid.for_ (qId <> c)] $ toHtml c
            QuestionDate -> do
                input_ $ [type_ "date", name_ questionText, ariaErrormessage_ errId] <> requiredAttrs
            QuestionInteger -> do
                let QuestionOptions{lowerBoundInclusive = lowerBound, upperBoundInclusive = upperBound} = questionOptions
                let validationScriptParts =
                        [ [__i|
                          on input
                            set my.value to my.value.replace('/[^0-9-]/g', '')
                          end
                        |]
                        , runJust
                            ""
                            lowerBound
                            ( \lb ->
                                [__i|
                            on input
                              if my.value < #{lb} then set my.value to #{lb}
                            end
                            |]
                            )
                        , runJust
                            ""
                            upperBound
                            ( \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 $ script_ validationScript
                        , Just $ ariaErrormessage_ errId
                        , Just $ id_ "integer"
                        , fmap (min_ . show) lowerBound
                        , fmap (max_ . show) upperBound
                        ]
                        <> requiredAttrs
            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, 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", script_ radioScript] <> requiredAttrs
                        label_ [Lucid.for_ (qId <> "cannot-say")] $ "Cannot say"
            QuestionTime -> do
                input_ $ [type_ "time", name_ questionText, ariaErrormessage_ errId] <> requiredAttrs
            QuestionFreeText -> do
                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, 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
    [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