devforms-0.1.1.0: src/Question.hs

{-# LANGUAGE QuasiQuotes #-}

module Question (Question (..), QuestionOptions (..), QuestionBuilder, 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

data Question = QuestionCheckbox Text | QuestionLikert Text | QuestionChoice Text [Text] | QuestionDate Text | QuestionInteger Text QuestionOptions | QuestionTime Text | QuestionText Text 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

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
                fieldset_ $ do
                    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
                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

                h3_ $ toHtml questionText
                input_ $
                    catMaybes
                        [ Just $ type_ "number"
                        , Just $ name_ questionText
                        , Just $ step_ "1"
                        , Just $ pattern_ "[0-9]+"
                        , Just $ required_ ""
                        , Just $ script_ validationScript
                        , fmap (min_ . show) lowerBoundInclusive
                        , fmap (max_ . show) upperBoundInclusive
                        ]
            QuestionLikert questionText -> do
                let choices =
                        [ "Strongly disagree" :: Text
                        , "Somewhat disagree"
                        , "Neither agree nor disagree"
                        , "Somewhat agree"
                        , "Strongly agree"
                        ]
                h3_ $ toHtml questionText
                forM_ choices $ \c -> do
                    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_ ""] ""

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 ->
        let value = JSON.Bool $ isJust $ Map.lookup questionText params
         in Right (Key.fromText questionText, value)
    QuestionInteger questionText 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 ->
        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 ->
        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 questionText ->
        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 ->
        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 ->
        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