devforms-0.2.1.0: src/Question.hs

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

module Question (
    Question (..),
    QuestionType (..),
    QuestionOptions (..),
    QuestionBuilder,
    IntegerQuestionBuilder,
    MultiChoiceQuestionBuilder,
    HasOptional (..),
    HasBounds (..),
    HasSelectionBounds (..),
    runQuestionBuilder,
    runIntegerQuestionBuilder,
    runMultiChoiceQuestionBuilder,
    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] | 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, minSelections = Nothing, maxSelections = 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)

-- | 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

-- | Typeclass for builders that support setting numeric bounds.
class HasBounds m where
    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}

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}

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

-- | Run an 'IntegerQuestionBuilder' to extract the configured 'QuestionOptions'.
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

{- | 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
            QuestionMultiChoice _ -> 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
            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
                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
            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"
                        , "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