{-# 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
    { Question -> Text
questionText :: Text
    , Question -> QuestionType
questionType :: QuestionType
    , Question -> QuestionOptions
questionOptions :: QuestionOptions
    }
    deriving (Int -> Question -> ShowS
[Question] -> ShowS
Question -> String
(Int -> Question -> ShowS)
-> (Question -> String) -> ([Question] -> ShowS) -> Show Question
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Question -> ShowS
showsPrec :: Int -> Question -> ShowS
$cshow :: Question -> String
show :: Question -> String
$cshowList :: [Question] -> ShowS
showList :: [Question] -> ShowS
Show)

data QuestionType = QuestionCheckbox | QuestionLikert | QuestionChoice [Text] | QuestionDate | QuestionInteger | QuestionTime | QuestionFreeText | QuestionRegexText Text deriving (Int -> QuestionType -> ShowS
[QuestionType] -> ShowS
QuestionType -> String
(Int -> QuestionType -> ShowS)
-> (QuestionType -> String)
-> ([QuestionType] -> ShowS)
-> Show QuestionType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QuestionType -> ShowS
showsPrec :: Int -> QuestionType -> ShowS
$cshow :: QuestionType -> String
show :: QuestionType -> String
$cshowList :: [QuestionType] -> ShowS
showList :: [QuestionType] -> ShowS
Show)

data QuestionOptions = QuestionOptions
    { QuestionOptions -> Bool
isOptional :: Bool
    , QuestionOptions -> Maybe Integer
lowerBoundInclusive :: Maybe Integer
    , QuestionOptions -> Maybe Integer
upperBoundInclusive :: Maybe Integer
    }
    deriving (Int -> QuestionOptions -> ShowS
[QuestionOptions] -> ShowS
QuestionOptions -> String
(Int -> QuestionOptions -> ShowS)
-> (QuestionOptions -> String)
-> ([QuestionOptions] -> ShowS)
-> Show QuestionOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QuestionOptions -> ShowS
showsPrec :: Int -> QuestionOptions -> ShowS
$cshow :: QuestionOptions -> String
show :: QuestionOptions -> String
$cshowList :: [QuestionOptions] -> ShowS
showList :: [QuestionOptions] -> ShowS
Show)

defaultOptions :: QuestionOptions
defaultOptions :: QuestionOptions
defaultOptions = QuestionOptions{isOptional :: Bool
isOptional = Bool
False, lowerBoundInclusive :: Maybe Integer
lowerBoundInclusive = Maybe Integer
forall a. Maybe a
Nothing, upperBoundInclusive :: Maybe Integer
upperBoundInclusive = Maybe Integer
forall a. Maybe a
Nothing}

-- | A builder monad for configuring shared question options (e.g. optionality).
newtype QuestionBuilder a = QuestionBuilder (Writer (Endo QuestionOptions) a)
    deriving newtype ((forall a b. (a -> b) -> QuestionBuilder a -> QuestionBuilder b)
-> (forall a b. a -> QuestionBuilder b -> QuestionBuilder a)
-> Functor QuestionBuilder
forall a b. a -> QuestionBuilder b -> QuestionBuilder a
forall a b. (a -> b) -> QuestionBuilder a -> QuestionBuilder b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> QuestionBuilder a -> QuestionBuilder b
fmap :: forall a b. (a -> b) -> QuestionBuilder a -> QuestionBuilder b
$c<$ :: forall a b. a -> QuestionBuilder b -> QuestionBuilder a
<$ :: forall a b. a -> QuestionBuilder b -> QuestionBuilder a
Functor, Functor QuestionBuilder
Functor QuestionBuilder =>
(forall a. a -> QuestionBuilder a)
-> (forall a b.
    QuestionBuilder (a -> b) -> QuestionBuilder a -> QuestionBuilder b)
-> (forall a b c.
    (a -> b -> c)
    -> QuestionBuilder a -> QuestionBuilder b -> QuestionBuilder c)
-> (forall a b.
    QuestionBuilder a -> QuestionBuilder b -> QuestionBuilder b)
-> (forall a b.
    QuestionBuilder a -> QuestionBuilder b -> QuestionBuilder a)
-> Applicative QuestionBuilder
forall a. a -> QuestionBuilder a
forall a b.
QuestionBuilder a -> QuestionBuilder b -> QuestionBuilder a
forall a b.
QuestionBuilder a -> QuestionBuilder b -> QuestionBuilder b
forall a b.
QuestionBuilder (a -> b) -> QuestionBuilder a -> QuestionBuilder b
forall a b c.
(a -> b -> c)
-> QuestionBuilder a -> QuestionBuilder b -> QuestionBuilder c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> QuestionBuilder a
pure :: forall a. a -> QuestionBuilder a
$c<*> :: forall a b.
QuestionBuilder (a -> b) -> QuestionBuilder a -> QuestionBuilder b
<*> :: forall a b.
QuestionBuilder (a -> b) -> QuestionBuilder a -> QuestionBuilder b
$cliftA2 :: forall a b c.
(a -> b -> c)
-> QuestionBuilder a -> QuestionBuilder b -> QuestionBuilder c
liftA2 :: forall a b c.
(a -> b -> c)
-> QuestionBuilder a -> QuestionBuilder b -> QuestionBuilder c
$c*> :: forall a b.
QuestionBuilder a -> QuestionBuilder b -> QuestionBuilder b
*> :: forall a b.
QuestionBuilder a -> QuestionBuilder b -> QuestionBuilder b
$c<* :: forall a b.
QuestionBuilder a -> QuestionBuilder b -> QuestionBuilder a
<* :: forall a b.
QuestionBuilder a -> QuestionBuilder b -> QuestionBuilder a
Applicative, Applicative QuestionBuilder
Applicative QuestionBuilder =>
(forall a b.
 QuestionBuilder a -> (a -> QuestionBuilder b) -> QuestionBuilder b)
-> (forall a b.
    QuestionBuilder a -> QuestionBuilder b -> QuestionBuilder b)
-> (forall a. a -> QuestionBuilder a)
-> Monad QuestionBuilder
forall a. a -> QuestionBuilder a
forall a b.
QuestionBuilder a -> QuestionBuilder b -> QuestionBuilder b
forall a b.
QuestionBuilder a -> (a -> QuestionBuilder b) -> QuestionBuilder b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b.
QuestionBuilder a -> (a -> QuestionBuilder b) -> QuestionBuilder b
>>= :: forall a b.
QuestionBuilder a -> (a -> QuestionBuilder b) -> QuestionBuilder b
$c>> :: forall a b.
QuestionBuilder a -> QuestionBuilder b -> QuestionBuilder b
>> :: forall a b.
QuestionBuilder a -> QuestionBuilder b -> QuestionBuilder b
$creturn :: forall a. a -> QuestionBuilder a
return :: forall a. a -> QuestionBuilder a
Monad)

-- | A builder monad for configuring integer question options (bounds and optionality).
newtype IntegerQuestionBuilder a = IntegerQuestionBuilder (Writer (Endo QuestionOptions) a)
    deriving newtype ((forall a b.
 (a -> b) -> IntegerQuestionBuilder a -> IntegerQuestionBuilder b)
-> (forall a b.
    a -> IntegerQuestionBuilder b -> IntegerQuestionBuilder a)
-> Functor IntegerQuestionBuilder
forall a b.
a -> IntegerQuestionBuilder b -> IntegerQuestionBuilder a
forall a b.
(a -> b) -> IntegerQuestionBuilder a -> IntegerQuestionBuilder b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b.
(a -> b) -> IntegerQuestionBuilder a -> IntegerQuestionBuilder b
fmap :: forall a b.
(a -> b) -> IntegerQuestionBuilder a -> IntegerQuestionBuilder b
$c<$ :: forall a b.
a -> IntegerQuestionBuilder b -> IntegerQuestionBuilder a
<$ :: forall a b.
a -> IntegerQuestionBuilder b -> IntegerQuestionBuilder a
Functor, Functor IntegerQuestionBuilder
Functor IntegerQuestionBuilder =>
(forall a. a -> IntegerQuestionBuilder a)
-> (forall a b.
    IntegerQuestionBuilder (a -> b)
    -> IntegerQuestionBuilder a -> IntegerQuestionBuilder b)
-> (forall a b c.
    (a -> b -> c)
    -> IntegerQuestionBuilder a
    -> IntegerQuestionBuilder b
    -> IntegerQuestionBuilder c)
-> (forall a b.
    IntegerQuestionBuilder a
    -> IntegerQuestionBuilder b -> IntegerQuestionBuilder b)
-> (forall a b.
    IntegerQuestionBuilder a
    -> IntegerQuestionBuilder b -> IntegerQuestionBuilder a)
-> Applicative IntegerQuestionBuilder
forall a. a -> IntegerQuestionBuilder a
forall a b.
IntegerQuestionBuilder a
-> IntegerQuestionBuilder b -> IntegerQuestionBuilder a
forall a b.
IntegerQuestionBuilder a
-> IntegerQuestionBuilder b -> IntegerQuestionBuilder b
forall a b.
IntegerQuestionBuilder (a -> b)
-> IntegerQuestionBuilder a -> IntegerQuestionBuilder b
forall a b c.
(a -> b -> c)
-> IntegerQuestionBuilder a
-> IntegerQuestionBuilder b
-> IntegerQuestionBuilder c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> IntegerQuestionBuilder a
pure :: forall a. a -> IntegerQuestionBuilder a
$c<*> :: forall a b.
IntegerQuestionBuilder (a -> b)
-> IntegerQuestionBuilder a -> IntegerQuestionBuilder b
<*> :: forall a b.
IntegerQuestionBuilder (a -> b)
-> IntegerQuestionBuilder a -> IntegerQuestionBuilder b
$cliftA2 :: forall a b c.
(a -> b -> c)
-> IntegerQuestionBuilder a
-> IntegerQuestionBuilder b
-> IntegerQuestionBuilder c
liftA2 :: forall a b c.
(a -> b -> c)
-> IntegerQuestionBuilder a
-> IntegerQuestionBuilder b
-> IntegerQuestionBuilder c
$c*> :: forall a b.
IntegerQuestionBuilder a
-> IntegerQuestionBuilder b -> IntegerQuestionBuilder b
*> :: forall a b.
IntegerQuestionBuilder a
-> IntegerQuestionBuilder b -> IntegerQuestionBuilder b
$c<* :: forall a b.
IntegerQuestionBuilder a
-> IntegerQuestionBuilder b -> IntegerQuestionBuilder a
<* :: forall a b.
IntegerQuestionBuilder a
-> IntegerQuestionBuilder b -> IntegerQuestionBuilder a
Applicative, Applicative IntegerQuestionBuilder
Applicative IntegerQuestionBuilder =>
(forall a b.
 IntegerQuestionBuilder a
 -> (a -> IntegerQuestionBuilder b) -> IntegerQuestionBuilder b)
-> (forall a b.
    IntegerQuestionBuilder a
    -> IntegerQuestionBuilder b -> IntegerQuestionBuilder b)
-> (forall a. a -> IntegerQuestionBuilder a)
-> Monad IntegerQuestionBuilder
forall a. a -> IntegerQuestionBuilder a
forall a b.
IntegerQuestionBuilder a
-> IntegerQuestionBuilder b -> IntegerQuestionBuilder b
forall a b.
IntegerQuestionBuilder a
-> (a -> IntegerQuestionBuilder b) -> IntegerQuestionBuilder b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b.
IntegerQuestionBuilder a
-> (a -> IntegerQuestionBuilder b) -> IntegerQuestionBuilder b
>>= :: forall a b.
IntegerQuestionBuilder a
-> (a -> IntegerQuestionBuilder b) -> IntegerQuestionBuilder b
$c>> :: forall a b.
IntegerQuestionBuilder a
-> IntegerQuestionBuilder b -> IntegerQuestionBuilder b
>> :: forall a b.
IntegerQuestionBuilder a
-> IntegerQuestionBuilder b -> IntegerQuestionBuilder b
$creturn :: forall a. a -> IntegerQuestionBuilder a
return :: forall a. a -> IntegerQuestionBuilder a
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 ()
setOptional = Writer (Endo QuestionOptions) () -> QuestionBuilder ()
forall a. Writer (Endo QuestionOptions) a -> QuestionBuilder a
QuestionBuilder (Writer (Endo QuestionOptions) () -> QuestionBuilder ())
-> Writer (Endo QuestionOptions) () -> QuestionBuilder ()
forall a b. (a -> b) -> a -> b
$ Endo QuestionOptions -> Writer (Endo QuestionOptions) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Endo QuestionOptions -> Writer (Endo QuestionOptions) ())
-> Endo QuestionOptions -> Writer (Endo QuestionOptions) ()
forall a b. (a -> b) -> a -> b
$ (QuestionOptions -> QuestionOptions) -> Endo QuestionOptions
forall a. (a -> a) -> Endo a
Endo ((QuestionOptions -> QuestionOptions) -> Endo QuestionOptions)
-> (QuestionOptions -> QuestionOptions) -> Endo QuestionOptions
forall a b. (a -> b) -> a -> b
$ \QuestionOptions
o -> QuestionOptions
o{isOptional = True}

instance HasOptional (IntegerQuestionBuilder ()) where
    setOptional :: IntegerQuestionBuilder ()
setOptional = Writer (Endo QuestionOptions) () -> IntegerQuestionBuilder ()
forall a.
Writer (Endo QuestionOptions) a -> IntegerQuestionBuilder a
IntegerQuestionBuilder (Writer (Endo QuestionOptions) () -> IntegerQuestionBuilder ())
-> Writer (Endo QuestionOptions) () -> IntegerQuestionBuilder ()
forall a b. (a -> b) -> a -> b
$ Endo QuestionOptions -> Writer (Endo QuestionOptions) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Endo QuestionOptions -> Writer (Endo QuestionOptions) ())
-> Endo QuestionOptions -> Writer (Endo QuestionOptions) ()
forall a b. (a -> b) -> a -> b
$ (QuestionOptions -> QuestionOptions) -> Endo QuestionOptions
forall a. (a -> a) -> Endo a
Endo ((QuestionOptions -> QuestionOptions) -> Endo QuestionOptions)
-> (QuestionOptions -> QuestionOptions) -> Endo QuestionOptions
forall a b. (a -> b) -> a -> b
$ \QuestionOptions
o -> QuestionOptions
o{isOptional = True}

instance HasBounds (IntegerQuestionBuilder ()) where
    setLowerBoundInclusive :: Integer -> IntegerQuestionBuilder ()
setLowerBoundInclusive Integer
bound = Writer (Endo QuestionOptions) () -> IntegerQuestionBuilder ()
forall a.
Writer (Endo QuestionOptions) a -> IntegerQuestionBuilder a
IntegerQuestionBuilder (Writer (Endo QuestionOptions) () -> IntegerQuestionBuilder ())
-> Writer (Endo QuestionOptions) () -> IntegerQuestionBuilder ()
forall a b. (a -> b) -> a -> b
$ Endo QuestionOptions -> Writer (Endo QuestionOptions) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Endo QuestionOptions -> Writer (Endo QuestionOptions) ())
-> Endo QuestionOptions -> Writer (Endo QuestionOptions) ()
forall a b. (a -> b) -> a -> b
$ (QuestionOptions -> QuestionOptions) -> Endo QuestionOptions
forall a. (a -> a) -> Endo a
Endo ((QuestionOptions -> QuestionOptions) -> Endo QuestionOptions)
-> (QuestionOptions -> QuestionOptions) -> Endo QuestionOptions
forall a b. (a -> b) -> a -> b
$ \QuestionOptions
o -> QuestionOptions
o{lowerBoundInclusive = Just bound}
    setUpperBoundInclusive :: Integer -> IntegerQuestionBuilder ()
setUpperBoundInclusive Integer
bound = Writer (Endo QuestionOptions) () -> IntegerQuestionBuilder ()
forall a.
Writer (Endo QuestionOptions) a -> IntegerQuestionBuilder a
IntegerQuestionBuilder (Writer (Endo QuestionOptions) () -> IntegerQuestionBuilder ())
-> Writer (Endo QuestionOptions) () -> IntegerQuestionBuilder ()
forall a b. (a -> b) -> a -> b
$ Endo QuestionOptions -> Writer (Endo QuestionOptions) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Endo QuestionOptions -> Writer (Endo QuestionOptions) ())
-> Endo QuestionOptions -> Writer (Endo QuestionOptions) ()
forall a b. (a -> b) -> a -> b
$ (QuestionOptions -> QuestionOptions) -> Endo QuestionOptions
forall a. (a -> a) -> Endo a
Endo ((QuestionOptions -> QuestionOptions) -> Endo QuestionOptions)
-> (QuestionOptions -> QuestionOptions) -> Endo QuestionOptions
forall a b. (a -> b) -> a -> b
$ \QuestionOptions
o -> QuestionOptions
o{upperBoundInclusive = Just bound}

data AnswerError = NoRegexMatch Text | MissingRequiredField Text | InvalidTimeFormatFor Text | InvalidDateFormatFor Text | InvalidLikertOptionFor Text | InvalidChoiceFor Text | InvalidIntegerFor Text IntegerBoundError | IntegerParseErrorFor Text deriving (Int -> AnswerError -> ShowS
[AnswerError] -> ShowS
AnswerError -> String
(Int -> AnswerError -> ShowS)
-> (AnswerError -> String)
-> ([AnswerError] -> ShowS)
-> Show AnswerError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AnswerError -> ShowS
showsPrec :: Int -> AnswerError -> ShowS
$cshow :: AnswerError -> String
show :: AnswerError -> String
$cshowList :: [AnswerError] -> ShowS
showList :: [AnswerError] -> ShowS
Show)

-- | Run a 'QuestionBuilder' to extract the configured 'QuestionOptions'.
runQuestionBuilder :: QuestionBuilder () -> QuestionOptions
runQuestionBuilder :: QuestionBuilder () -> QuestionOptions
runQuestionBuilder (QuestionBuilder Writer (Endo QuestionOptions) ()
w) = Endo QuestionOptions -> QuestionOptions -> QuestionOptions
forall a. Endo a -> a -> a
appEndo (Writer (Endo QuestionOptions) () -> Endo QuestionOptions
forall w a. Writer w a -> w
execWriter Writer (Endo QuestionOptions) ()
w) QuestionOptions
defaultOptions

-- | Run an 'IntegerQuestionBuilder' to extract the configured 'QuestionOptions'.
runIntegerQuestionBuilder :: IntegerQuestionBuilder () -> QuestionOptions
runIntegerQuestionBuilder :: IntegerQuestionBuilder () -> QuestionOptions
runIntegerQuestionBuilder (IntegerQuestionBuilder Writer (Endo QuestionOptions) ()
w) = Endo QuestionOptions -> QuestionOptions -> QuestionOptions
forall a. Endo a -> a -> a
appEndo (Writer (Endo QuestionOptions) () -> Endo QuestionOptions
forall w a. Writer w a -> w
execWriter Writer (Endo QuestionOptions) ()
w) QuestionOptions
defaultOptions

runJust :: a -> Maybe b -> (b -> a) -> a
runJust :: forall a b. a -> Maybe b -> (b -> a) -> a
runJust a
_ (Just b
x) b -> a
f = b -> a
f b
x
runJust a
defaultValue Maybe b
Nothing b -> a
_ = a
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 :: Text -> Text
validationId Text
questionText = Text
"err " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
questionText

renderQuestion :: Question -> Html ()
renderQuestion :: Question -> HtmlT Identity ()
renderQuestion Question{Text
questionText :: Question -> Text
questionText :: Text
questionText, QuestionType
questionType :: Question -> QuestionType
questionType :: QuestionType
questionType, QuestionOptions
questionOptions :: Question -> QuestionOptions
questionOptions :: QuestionOptions
questionOptions} = do
    [Attributes] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attributes
class_ Text
"input"] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ do
        let qId :: Text
qId = Text
questionText
        let errId :: Text
errId = Text -> Text
validationId Text
questionText
        let isRequired :: Bool
isRequired = Bool -> Bool
not (QuestionOptions -> Bool
isOptional QuestionOptions
questionOptions)
        let requiredAttrs :: [Attributes]
requiredAttrs = if Bool
isRequired then [Text -> Attributes
required_ Text
""] else []
        case QuestionType
questionType of
            QuestionChoice [Text]
_ -> HtmlT Identity ()
forall a. Monoid a => a
mempty
            QuestionType
QuestionLikert -> HtmlT Identity ()
forall a. Monoid a => a
mempty
            QuestionType
_ -> [Attributes] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
label_ [Text -> Attributes
Lucid.for_ Text
qId] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml Text
questionText
        case QuestionType
questionType of
            QuestionType
QuestionCheckbox -> do
                [Attributes] -> HtmlT Identity ()
forall (m :: * -> *). Monad m => [Attributes] -> HtmlT m ()
input_ [Text -> Attributes
id_ Text
qId, Text -> Attributes
type_ Text
"checkbox", Text -> Attributes
name_ Text
questionText]
            QuestionChoice [Text]
choices -> do
                let radioScript :: Text
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
                HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
fieldset_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ do
                    HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
legend_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml Text
questionText
                    [Text] -> (Text -> HtmlT Identity ()) -> HtmlT Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
choices ((Text -> HtmlT Identity ()) -> HtmlT Identity ())
-> (Text -> HtmlT Identity ()) -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ \Text
c -> do
                        HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ do
                            [Attributes] -> HtmlT Identity ()
forall (m :: * -> *). Monad m => [Attributes] -> HtmlT m ()
input_ ([Attributes] -> HtmlT Identity ())
-> [Attributes] -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ [Text -> Attributes
id_ (Text
qId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c), Text -> Attributes
type_ Text
"radio", Text -> Attributes
name_ Text
qId, Text -> Attributes
value_ Text
c, Text -> Attributes
ariaErrormessage_ Text
errId, Text -> Attributes
forall arg result. TermRaw arg result => arg -> result
script_ Text
radioScript] [Attributes] -> [Attributes] -> [Attributes]
forall a. Semigroup a => a -> a -> a
<> [Attributes]
requiredAttrs
                            [Attributes] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
label_ [Text -> Attributes
Lucid.for_ (Text
qId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c)] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml Text
c
            QuestionType
QuestionDate -> do
                [Attributes] -> HtmlT Identity ()
forall (m :: * -> *). Monad m => [Attributes] -> HtmlT m ()
input_ ([Attributes] -> HtmlT Identity ())
-> [Attributes] -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ [Text -> Attributes
type_ Text
"date", Text -> Attributes
name_ Text
questionText, Text -> Attributes
ariaErrormessage_ Text
errId] [Attributes] -> [Attributes] -> [Attributes]
forall a. Semigroup a => a -> a -> a
<> [Attributes]
requiredAttrs
            QuestionType
QuestionInteger -> do
                let QuestionOptions{lowerBoundInclusive :: QuestionOptions -> Maybe Integer
lowerBoundInclusive = Maybe Integer
lowerBound, upperBoundInclusive :: QuestionOptions -> Maybe Integer
upperBoundInclusive = Maybe Integer
upperBound} = QuestionOptions
questionOptions
                let validationScriptParts :: [Text]
validationScriptParts =
                        [ [__i|
                          on input
                            set my.value to my.value.replace('/[^0-9-]/g', '')
                          end
                        |]
                        , Text -> Maybe Integer -> (Integer -> Text) -> Text
forall a b. a -> Maybe b -> (b -> a) -> a
runJust
                            Text
""
                            Maybe Integer
lowerBound
                            ( \Integer
lb ->
                                [__i|
                            on input
                              if my.value < #{lb} then set my.value to #{lb}
                            end
                            |]
                            )
                        , Text -> Maybe Integer -> (Integer -> Text) -> Text
forall a b. a -> Maybe b -> (b -> a) -> a
runJust
                            Text
""
                            Maybe Integer
upperBound
                            ( \Integer
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
validationScript = Text -> [Text] -> Text
Text.intercalate Text
"\n" [Text]
validationScriptParts

                [Attributes] -> HtmlT Identity ()
forall (m :: * -> *). Monad m => [Attributes] -> HtmlT m ()
input_ ([Attributes] -> HtmlT Identity ())
-> [Attributes] -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$
                    [Maybe Attributes] -> [Attributes]
forall a. [Maybe a] -> [a]
catMaybes
                        [ Attributes -> Maybe Attributes
forall a. a -> Maybe a
Just (Attributes -> Maybe Attributes) -> Attributes -> Maybe Attributes
forall a b. (a -> b) -> a -> b
$ Text -> Attributes
type_ Text
"number"
                        , Attributes -> Maybe Attributes
forall a. a -> Maybe a
Just (Attributes -> Maybe Attributes) -> Attributes -> Maybe Attributes
forall a b. (a -> b) -> a -> b
$ Text -> Attributes
name_ Text
questionText
                        , Attributes -> Maybe Attributes
forall a. a -> Maybe a
Just (Attributes -> Maybe Attributes) -> Attributes -> Maybe Attributes
forall a b. (a -> b) -> a -> b
$ Text -> Attributes
step_ Text
"1"
                        , Attributes -> Maybe Attributes
forall a. a -> Maybe a
Just (Attributes -> Maybe Attributes) -> Attributes -> Maybe Attributes
forall a b. (a -> b) -> a -> b
$ Text -> Attributes
pattern_ Text
"[0-9]+"
                        , Attributes -> Maybe Attributes
forall a. a -> Maybe a
Just (Attributes -> Maybe Attributes) -> Attributes -> Maybe Attributes
forall a b. (a -> b) -> a -> b
$ Text -> Attributes
forall arg result. TermRaw arg result => arg -> result
script_ Text
validationScript
                        , Attributes -> Maybe Attributes
forall a. a -> Maybe a
Just (Attributes -> Maybe Attributes) -> Attributes -> Maybe Attributes
forall a b. (a -> b) -> a -> b
$ Text -> Attributes
ariaErrormessage_ Text
errId
                        , Attributes -> Maybe Attributes
forall a. a -> Maybe a
Just (Attributes -> Maybe Attributes) -> Attributes -> Maybe Attributes
forall a b. (a -> b) -> a -> b
$ Text -> Attributes
id_ Text
"integer"
                        , (Integer -> Attributes) -> Maybe Integer -> Maybe Attributes
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Attributes
min_ (Text -> Attributes) -> (Integer -> Text) -> Integer -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Text
forall b a. (Show a, IsString b) => a -> b
show) Maybe Integer
lowerBound
                        , (Integer -> Attributes) -> Maybe Integer -> Maybe Attributes
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Attributes
max_ (Text -> Attributes) -> (Integer -> Text) -> Integer -> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Text
forall b a. (Show a, IsString b) => a -> b
show) Maybe Integer
upperBound
                        ]
                        [Attributes] -> [Attributes] -> [Attributes]
forall a. Semigroup a => a -> a -> a
<> [Attributes]
requiredAttrs
            QuestionType
QuestionLikert -> do
                let radioScript :: Text
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 :: [Text]
choices =
                        [ Text
"Strongly disagree" :: Text
                        , Text
"Somewhat disagree"
                        , Text
"Neither agree nor disagree"
                        , Text
"Somewhat agree"
                        , Text
"Strongly agree"
                        ]
                HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
fieldset_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ do
                    HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
legend_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml Text
questionText
                    [Text] -> (Text -> HtmlT Identity ()) -> HtmlT Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Text]
choices ((Text -> HtmlT Identity ()) -> HtmlT Identity ())
-> (Text -> HtmlT Identity ()) -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ \Text
c -> do
                        HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ do
                            [Attributes] -> HtmlT Identity ()
forall (m :: * -> *). Monad m => [Attributes] -> HtmlT m ()
input_ ([Attributes] -> HtmlT Identity ())
-> [Attributes] -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ [Text -> Attributes
id_ (Text
qId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c), Text -> Attributes
type_ Text
"radio", Text -> Attributes
name_ Text
qId, Text -> Attributes
value_ Text
c, Text -> Attributes
ariaErrormessage_ Text
errId, Text -> Attributes
forall arg result. TermRaw arg result => arg -> result
script_ Text
radioScript] [Attributes] -> [Attributes] -> [Attributes]
forall a. Semigroup a => a -> a -> a
<> [Attributes]
requiredAttrs
                            [Attributes] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
label_ [Text -> Attributes
Lucid.for_ (Text
qId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c)] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ Text -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => Text -> HtmlT m ()
toHtml Text
c
                    HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ do
                        [Attributes] -> HtmlT Identity ()
forall (m :: * -> *). Monad m => [Attributes] -> HtmlT m ()
input_ ([Attributes] -> HtmlT Identity ())
-> [Attributes] -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ [Text -> Attributes
id_ (Text
qId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"cannot-say"), Text -> Attributes
type_ Text
"radio", Text -> Attributes
name_ Text
qId, Text -> Attributes
value_ Text
"Cannot say", Text -> Attributes
forall arg result. TermRaw arg result => arg -> result
script_ Text
radioScript] [Attributes] -> [Attributes] -> [Attributes]
forall a. Semigroup a => a -> a -> a
<> [Attributes]
requiredAttrs
                        [Attributes] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
label_ [Text -> Attributes
Lucid.for_ (Text
qId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"cannot-say")] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ HtmlT Identity ()
"Cannot say"
            QuestionType
QuestionTime -> do
                [Attributes] -> HtmlT Identity ()
forall (m :: * -> *). Monad m => [Attributes] -> HtmlT m ()
input_ ([Attributes] -> HtmlT Identity ())
-> [Attributes] -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ [Text -> Attributes
type_ Text
"time", Text -> Attributes
name_ Text
questionText, Text -> Attributes
ariaErrormessage_ Text
errId] [Attributes] -> [Attributes] -> [Attributes]
forall a. Semigroup a => a -> a -> a
<> [Attributes]
requiredAttrs
            QuestionType
QuestionFreeText -> do
                [Attributes] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
textarea_ ([Text -> Attributes
name_ Text
questionText, Text -> Attributes
ariaErrormessage_ Text
errId] [Attributes] -> [Attributes] -> [Attributes]
forall a. Semigroup a => a -> a -> a
<> [Attributes]
requiredAttrs) HtmlT Identity ()
""
            QuestionRegexText Text
regexPattern -> do
                [Attributes] -> HtmlT Identity ()
forall (m :: * -> *). Monad m => [Attributes] -> HtmlT m ()
input_ ([Attributes] -> HtmlT Identity ())
-> [Attributes] -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ [Text -> Attributes
type_ Text
"text", Text -> Attributes
pattern_ Text
regexPattern, Text -> Attributes
name_ Text
questionText, Text -> Attributes
ariaErrormessage_ Text
errId] [Attributes] -> [Attributes] -> [Attributes]
forall a. Semigroup a => a -> a -> a
<> [Attributes]
requiredAttrs
        Bool -> HtmlT Identity () -> HtmlT Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (QuestionOptions -> Bool
isOptional QuestionOptions
questionOptions) (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$
            [Attributes] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attributes
class_ Text
"hint"] HtmlT Identity ()
"Optional"
        [Attributes] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attributes
id_ Text
errId, Text -> Attributes
class_ Text
"validation-message"] HtmlT Identity ()
forall a. Monoid a => a
mempty

ariaErrormessage_ :: Text -> Attributes
ariaErrormessage_ :: Text -> Attributes
ariaErrormessage_ = Text -> Text -> Attributes
forall arg result. Term arg result => Text -> arg -> result
term Text
"aria-errormessage"

mapLeft :: (a -> c) -> Either a b -> Either c b
mapLeft :: forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft a -> c
f (Left a
e) = c -> Either c b
forall a b. a -> Either a b
Left (a -> c
f a
e)
mapLeft a -> c
_ (Right b
v) = (b -> Either c b
forall a b. b -> Either a b
Right b
v)

parseAnswers :: [Question] -> Map Text Text -> Either Text [(JSON.Key, JSON.Value)]
parseAnswers :: [Question] -> Map Text Text -> Either Text [(Key, Value)]
parseAnswers [Question]
questions Map Text Text
params = (Question -> Either Text (Key, Value))
-> [Question] -> Either Text [(Key, Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Question -> Map Text Text -> Either Text (Key, Value)
`parseAnswer` Map Text Text
params) [Question]
questions

parseAnswer :: Question -> Map Text Text -> Either Text (JSON.Key, JSON.Value)
parseAnswer :: Question -> Map Text Text -> Either Text (Key, Value)
parseAnswer Question{Text
questionText :: Question -> Text
questionText :: Text
questionText, QuestionType
questionType :: Question -> QuestionType
questionType :: QuestionType
questionType, QuestionOptions
questionOptions :: Question -> QuestionOptions
questionOptions :: QuestionOptions
questionOptions} Map Text Text
params =
    case Either AnswerError (Key, Value)
result of
        Left AnswerError
e -> Text -> Either Text (Key, Value)
forall a b. a -> Either a b
Left (Text -> Either Text (Key, Value))
-> Text -> Either Text (Key, Value)
forall a b. (a -> b) -> a -> b
$ AnswerError -> Text
forall b a. (Show a, IsString b) => a -> b
show AnswerError
e
        Right (Key, Value)
parsed -> (Key, Value) -> Either Text (Key, Value)
forall a b. b -> Either a b
Right (Key, Value)
parsed
  where
    -- Normalize: treat empty/whitespace-only values as missing for optional fields
    params' :: Map Text Text
params'
        | QuestionOptions -> Bool
isOptional QuestionOptions
questionOptions =
            case Key (Map Text Text) -> Map Text Text -> Maybe (Val (Map Text Text))
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
Map.lookup Text
Key (Map Text Text)
questionText Map Text Text
params of
                Just Val (Map Text Text)
v | Text -> Bool
Text.null (Text -> Text
Text.strip Text
Val (Map Text Text)
v) -> Key (Map Text Text) -> Map Text Text -> Map Text Text
forall t. DynamicMap t => Key t -> t -> t
Map.delete Text
Key (Map Text Text)
questionText Map Text Text
params
                Maybe (Val (Map Text Text))
_ -> Map Text Text
params
        | Bool
otherwise = Map Text Text
params

    result :: Either AnswerError (Key, Value)
result =
        case QuestionType
questionType of
            QuestionType
QuestionCheckbox ->
                let value :: Value
value = Bool -> Value
JSON.Bool (Bool -> Value) -> Bool -> Value
forall a b. (a -> b) -> a -> b
$ Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Text -> Bool) -> Maybe Text -> Bool
forall a b. (a -> b) -> a -> b
$ Key (Map Text Text) -> Map Text Text -> Maybe (Val (Map Text Text))
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
Map.lookup Text
Key (Map Text Text)
questionText Map Text Text
params'
                 in (Key, Value) -> Either AnswerError (Key, Value)
forall a b. b -> Either a b
Right (Text -> Key
Key.fromText Text
questionText, Value
value)
            QuestionType
QuestionInteger -> do
                let QuestionOptions{lowerBoundInclusive :: QuestionOptions -> Maybe Integer
lowerBoundInclusive = Maybe Integer
lowerBound, upperBoundInclusive :: QuestionOptions -> Maybe Integer
upperBoundInclusive = Maybe Integer
upperBound} = QuestionOptions
questionOptions
                case Key (Map Text Text) -> Map Text Text -> Maybe (Val (Map Text Text))
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
Map.lookup Text
Key (Map Text Text)
questionText Map Text Text
params' of
                    Maybe (Val (Map Text Text))
Nothing
                        | QuestionOptions -> Bool
isOptional QuestionOptions
questionOptions -> (Key, Value) -> Either AnswerError (Key, Value)
forall a b. b -> Either a b
Right (Text -> Key
Key.fromText Text
questionText, Value
JSON.Null)
                        | Bool
otherwise -> AnswerError -> Either AnswerError (Key, Value)
forall a b. a -> Either a b
Left (AnswerError -> Either AnswerError (Key, Value))
-> AnswerError -> Either AnswerError (Key, Value)
forall a b. (a -> b) -> a -> b
$ Text -> AnswerError
MissingRequiredField Text
questionText
                    Just Val (Map Text Text)
raw -> do
                        Integer
n <- AnswerError -> Maybe Integer -> Either AnswerError Integer
forall l r. l -> Maybe r -> Either l r
maybeToRight (Text -> AnswerError
IntegerParseErrorFor Text
questionText) (String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
forall a. ToString a => a -> String
toString Text
Val (Map Text Text)
raw) :: Maybe Integer)
                        ParsedInteger
boundsCheckedInt <- (IntegerBoundError -> AnswerError)
-> Either IntegerBoundError ParsedInteger
-> Either AnswerError ParsedInteger
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft (Text -> IntegerBoundError -> AnswerError
InvalidIntegerFor Text
questionText) (Either IntegerBoundError ParsedInteger
 -> Either AnswerError ParsedInteger)
-> Either IntegerBoundError ParsedInteger
-> Either AnswerError ParsedInteger
forall a b. (a -> b) -> a -> b
$ Maybe Integer
-> Maybe Integer
-> Integer
-> Either IntegerBoundError ParsedInteger
parseWithBounds Maybe Integer
lowerBound Maybe Integer
upperBound Integer
n
                        (Key, Value) -> Either AnswerError (Key, Value)
forall a. a -> Either AnswerError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Key
Key.fromText Text
questionText, Integer -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON (ParsedInteger -> Integer
parsedToInteger ParsedInteger
boundsCheckedInt))
            QuestionChoice [Text]
choices ->
                case Key (Map Text Text) -> Map Text Text -> Maybe (Val (Map Text Text))
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
Map.lookup Text
Key (Map Text Text)
questionText Map Text Text
params' of
                    Maybe (Val (Map Text Text))
Nothing
                        | QuestionOptions -> Bool
isOptional QuestionOptions
questionOptions -> (Key, Value) -> Either AnswerError (Key, Value)
forall a b. b -> Either a b
Right (Text -> Key
Key.fromText Text
questionText, Value
JSON.Null)
                        | Bool
otherwise -> AnswerError -> Either AnswerError (Key, Value)
forall a b. a -> Either a b
Left (AnswerError -> Either AnswerError (Key, Value))
-> AnswerError -> Either AnswerError (Key, Value)
forall a b. (a -> b) -> a -> b
$ Text -> AnswerError
MissingRequiredField Text
questionText
                    Just Val (Map Text Text)
raw
                        | Text
Val (Map Text Text)
raw Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Text]
choices -> (Key, Value) -> Either AnswerError (Key, Value)
forall a b. b -> Either a b
Right (Text -> Key
Key.fromText Text
questionText, Text -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON Text
Val (Map Text Text)
raw)
                        | Bool
otherwise -> AnswerError -> Either AnswerError (Key, Value)
forall a b. a -> Either a b
Left (AnswerError -> Either AnswerError (Key, Value))
-> AnswerError -> Either AnswerError (Key, Value)
forall a b. (a -> b) -> a -> b
$ Text -> AnswerError
InvalidChoiceFor Text
questionText
            QuestionType
QuestionLikert ->
                let likertOptions :: [Text]
likertOptions =
                        [ Text
"Strongly disagree"
                        , Text
"Somewhat disagree"
                        , Text
"Neither agree nor disagree"
                        , Text
"Somewhat agree"
                        , Text
"Strongly agree"
                        , Text
"Cannot say"
                        ]
                 in case Key (Map Text Text) -> Map Text Text -> Maybe (Val (Map Text Text))
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
Map.lookup Text
Key (Map Text Text)
questionText Map Text Text
params' of
                        Maybe (Val (Map Text Text))
Nothing
                            | QuestionOptions -> Bool
isOptional QuestionOptions
questionOptions -> (Key, Value) -> Either AnswerError (Key, Value)
forall a b. b -> Either a b
Right (Text -> Key
Key.fromText Text
questionText, Value
JSON.Null)
                            | Bool
otherwise -> AnswerError -> Either AnswerError (Key, Value)
forall a b. a -> Either a b
Left (AnswerError -> Either AnswerError (Key, Value))
-> AnswerError -> Either AnswerError (Key, Value)
forall a b. (a -> b) -> a -> b
$ Text -> AnswerError
MissingRequiredField Text
questionText
                        Just Val (Map Text Text)
raw
                            | Text
Val (Map Text Text)
raw Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [Text]
likertOptions -> (Key, Value) -> Either AnswerError (Key, Value)
forall a b. b -> Either a b
Right (Text -> Key
Key.fromText Text
questionText, Text -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON Text
Val (Map Text Text)
raw)
                            | Bool
otherwise -> AnswerError -> Either AnswerError (Key, Value)
forall a b. a -> Either a b
Left (AnswerError -> Either AnswerError (Key, Value))
-> AnswerError -> Either AnswerError (Key, Value)
forall a b. (a -> b) -> a -> b
$ Text -> AnswerError
InvalidLikertOptionFor Text
questionText
            QuestionType
QuestionDate ->
                case Key (Map Text Text) -> Map Text Text -> Maybe (Val (Map Text Text))
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
Map.lookup Text
Key (Map Text Text)
questionText Map Text Text
params' of
                    Maybe (Val (Map Text Text))
Nothing
                        | QuestionOptions -> Bool
isOptional QuestionOptions
questionOptions -> (Key, Value) -> Either AnswerError (Key, Value)
forall a b. b -> Either a b
Right (Text -> Key
Key.fromText Text
questionText, Value
JSON.Null)
                        | Bool
otherwise -> AnswerError -> Either AnswerError (Key, Value)
forall a b. a -> Either a b
Left (AnswerError -> Either AnswerError (Key, Value))
-> AnswerError -> Either AnswerError (Key, Value)
forall a b. (a -> b) -> a -> b
$ Text -> AnswerError
MissingRequiredField Text
questionText
                    Just Val (Map Text Text)
raw
                        | Text -> Bool
isValidDate Text
Val (Map Text Text)
raw -> (Key, Value) -> Either AnswerError (Key, Value)
forall a b. b -> Either a b
Right (Text -> Key
Key.fromText Text
questionText, Text -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON Text
Val (Map Text Text)
raw)
                        | Bool
otherwise -> AnswerError -> Either AnswerError (Key, Value)
forall a b. a -> Either a b
Left (AnswerError -> Either AnswerError (Key, Value))
-> AnswerError -> Either AnswerError (Key, Value)
forall a b. (a -> b) -> a -> b
$ Text -> AnswerError
InvalidDateFormatFor Text
questionText
            QuestionType
QuestionTime ->
                case Key (Map Text Text) -> Map Text Text -> Maybe (Val (Map Text Text))
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
Map.lookup Text
Key (Map Text Text)
questionText Map Text Text
params' of
                    Maybe (Val (Map Text Text))
Nothing
                        | QuestionOptions -> Bool
isOptional QuestionOptions
questionOptions -> (Key, Value) -> Either AnswerError (Key, Value)
forall a b. b -> Either a b
Right (Text -> Key
Key.fromText Text
questionText, Value
JSON.Null)
                        | Bool
otherwise -> AnswerError -> Either AnswerError (Key, Value)
forall a b. a -> Either a b
Left (AnswerError -> Either AnswerError (Key, Value))
-> AnswerError -> Either AnswerError (Key, Value)
forall a b. (a -> b) -> a -> b
$ Text -> AnswerError
MissingRequiredField Text
questionText
                    Just Val (Map Text Text)
raw
                        | Text -> Bool
isValidTime Text
Val (Map Text Text)
raw -> (Key, Value) -> Either AnswerError (Key, Value)
forall a b. b -> Either a b
Right (Text -> Key
Key.fromText Text
questionText, Text -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON Text
Val (Map Text Text)
raw)
                        | Bool
otherwise -> AnswerError -> Either AnswerError (Key, Value)
forall a b. a -> Either a b
Left (AnswerError -> Either AnswerError (Key, Value))
-> AnswerError -> Either AnswerError (Key, Value)
forall a b. (a -> b) -> a -> b
$ Text -> AnswerError
InvalidTimeFormatFor Text
questionText
            QuestionType
QuestionFreeText ->
                case Key (Map Text Text) -> Map Text Text -> Maybe (Val (Map Text Text))
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
Map.lookup Text
Key (Map Text Text)
questionText Map Text Text
params' of
                    Maybe (Val (Map Text Text))
Nothing
                        | QuestionOptions -> Bool
isOptional QuestionOptions
questionOptions -> (Key, Value) -> Either AnswerError (Key, Value)
forall a b. b -> Either a b
Right (Text -> Key
Key.fromText Text
questionText, Value
JSON.Null)
                        | Bool
otherwise -> AnswerError -> Either AnswerError (Key, Value)
forall a b. a -> Either a b
Left (AnswerError -> Either AnswerError (Key, Value))
-> AnswerError -> Either AnswerError (Key, Value)
forall a b. (a -> b) -> a -> b
$ Text -> AnswerError
MissingRequiredField Text
questionText
                    Just Val (Map Text Text)
raw
                        | Text -> Bool
Text.null (Text -> Text
Text.strip Text
Val (Map Text Text)
raw) -> AnswerError -> Either AnswerError (Key, Value)
forall a b. a -> Either a b
Left (AnswerError -> Either AnswerError (Key, Value))
-> AnswerError -> Either AnswerError (Key, Value)
forall a b. (a -> b) -> a -> b
$ Text -> AnswerError
MissingRequiredField Text
questionText
                        | Bool
otherwise -> (Key, Value) -> Either AnswerError (Key, Value)
forall a b. b -> Either a b
Right (Text -> Key
Key.fromText Text
questionText, Text -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON Text
Val (Map Text Text)
raw)
            QuestionRegexText Text
regex -> do
                case Key (Map Text Text) -> Map Text Text -> Maybe (Val (Map Text Text))
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
Map.lookup Text
Key (Map Text Text)
questionText Map Text Text
params' of
                    Maybe (Val (Map Text Text))
Nothing -> if QuestionOptions -> Bool
isOptional QuestionOptions
questionOptions then (Key, Value) -> Either AnswerError (Key, Value)
forall a b. b -> Either a b
Right (Text -> Key
Key.fromText Text
questionText, Value
JSON.Null) else AnswerError -> Either AnswerError (Key, Value)
forall a b. a -> Either a b
Left (Text -> AnswerError
MissingRequiredField Text
questionText)
                    Just Val (Map Text Text)
answer -> if Text
Val (Map Text Text)
answer Text -> Text -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ (Text
"^" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
regex Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"$") then (Key, Value) -> Either AnswerError (Key, Value)
forall a. a -> Either AnswerError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Key
Key.fromText Text
questionText, Text -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON Text
Val (Map Text Text)
answer) else AnswerError -> Either AnswerError (Key, Value)
forall a b. a -> Either a b
Left (Text -> AnswerError
NoRegexMatch Text
questionText)

isValidDate :: Text -> Bool
isValidDate :: Text -> Bool
isValidDate Text
t = case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"-" Text
t of
    [Text
y, Text
m, Text
d] ->
        Text -> Int
Text.length Text
y Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4
            Bool -> Bool -> Bool
&& Text -> Int
Text.length Text
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
            Bool -> Bool -> Bool
&& Text -> Int
Text.length Text
d Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
            Bool -> Bool -> Bool
&& Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
forall a. ToString a => a -> String
toString Text
y) :: Maybe Int)
            Bool -> Bool -> Bool
&& Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
forall a. ToString a => a -> String
toString Text
m) :: Maybe Int)
            Bool -> Bool -> Bool
&& Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
forall a. ToString a => a -> String
toString Text
d) :: Maybe Int)
    [Text]
_ -> Bool
False

isValidTime :: Text -> Bool
isValidTime :: Text -> Bool
isValidTime Text
t = case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
":" Text
t of
    [Text
h, Text
m] ->
        Text -> Int
Text.length Text
h Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
            Bool -> Bool -> Bool
&& Text -> Int
Text.length Text
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
            Bool -> Bool -> Bool
&& Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
forall a. ToString a => a -> String
toString Text
h) :: Maybe Int)
            Bool -> Bool -> Bool
&& Maybe Int -> Bool
forall a. Maybe a -> Bool
isJust (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
forall a. ToString a => a -> String
toString Text
m) :: Maybe Int)
    [Text]
_ -> Bool
False