{-# 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 Relude.Extra.Map as Map

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

-- | A builder monad for configuring question options (e.g. bounds for integer questions).
type QuestionBuilder = Writer (Endo QuestionOptions)

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

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

renderQuestion :: Question -> Html ()
renderQuestion :: Question -> HtmlT Identity ()
renderQuestion Question
question = do
    HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
section_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ do
        case Question
question of
            QuestionCheckbox Text
questionText -> do
                HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
h3_ (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
                [Attributes] -> HtmlT Identity ()
forall (m :: * -> *). Monad m => [Attributes] -> HtmlT m ()
input_ [Text -> Attributes
type_ Text
"checkbox", Text -> Attributes
name_ Text
questionText]
            QuestionChoice Text
questionText [Text]
choices -> do
                HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
h3_ (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
                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
                    [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_ [Text -> Attributes
type_ Text
"radio", Text -> Attributes
name_ Text
questionText, Text -> Attributes
value_ Text
c, Text -> Attributes
required_ Text
""]
                            [Attributes] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
label_ [Text -> Attributes
Lucid.for_ Text
questionText] (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
            QuestionDate Text
questionText -> do
                HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
h3_ (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
                [Attributes] -> HtmlT Identity ()
forall (m :: * -> *). Monad m => [Attributes] -> HtmlT m ()
input_ [Text -> Attributes
type_ Text
"date", Text -> Attributes
name_ Text
questionText, Text -> Attributes
required_ Text
""]
            QuestionInteger Text
questionText (QuestionOptions{Maybe Integer
lowerBoundInclusive :: QuestionOptions -> Maybe Integer
lowerBoundInclusive :: Maybe Integer
lowerBoundInclusive, Maybe Integer
upperBoundInclusive :: QuestionOptions -> Maybe Integer
upperBoundInclusive :: Maybe Integer
upperBoundInclusive}) -> do
                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
lowerBoundInclusive
                                ( \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
upperBoundInclusive
                                ( \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

                HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
h3_ (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
                [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
required_ Text
""
                        , 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
                        , (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
lowerBoundInclusive
                        , (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
upperBoundInclusive
                        ]
            QuestionLikert Text
questionText -> do
                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
h3_ (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_ [Text -> Attributes
type_ Text
"radio", Text -> Attributes
name_ Text
questionText, Text -> Attributes
value_ Text
c, Text -> Attributes
required_ Text
""]
                        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_ [Text -> Attributes
type_ Text
"radio", Text -> Attributes
name_ Text
questionText, Text -> Attributes
value_ Text
"Cannot say", Text -> Attributes
required_ Text
""]
                    HtmlT Identity ()
"Cannot say"
            QuestionTime Text
questionText -> do
                HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
h3_ (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
                [Attributes] -> HtmlT Identity ()
forall (m :: * -> *). Monad m => [Attributes] -> HtmlT m ()
input_ [Text -> Attributes
type_ Text
"time", Text -> Attributes
name_ Text
questionText, Text -> Attributes
required_ Text
""]

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
question Map Text Text
params = case Question
question of
    QuestionCheckbox Text
questionText ->
        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 Text (Key, Value)
forall a b. b -> Either a b
Right (Text -> Key
Key.fromText Text
questionText, Value
value)
    QuestionInteger Text
questionText QuestionOptions
opts ->
        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 -> 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
$ Text
"Missing required field: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
questionText
            Just Val (Map Text Text)
raw -> case 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 of
                Maybe Integer
Nothing -> 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
$ Text
"Invalid integer for: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
questionText
                Just Integer
n -> do
                    Text -> Integer -> QuestionOptions -> Either Text ()
validateBounds Text
questionText Integer
n QuestionOptions
opts
                    (Key, Value) -> Either Text (Key, Value)
forall a b. b -> Either a b
Right (Text -> Key
Key.fromText Text
questionText, Integer -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON Integer
n)
    QuestionChoice Text
questionText [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 -> 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
$ Text
"Missing required field: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> 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 Text (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 -> 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
$ Text
"Invalid choice for: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
questionText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
Val (Map Text Text)
raw
    QuestionLikert Text
questionText ->
        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)
lookup Text
Key (Map Text Text)
questionText Map Text Text
params of
                Maybe (Val (Map Text Text))
Nothing -> 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
$ Text
"Missing required field: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> 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 Text (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 -> 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
$ Text
"Invalid Likert option for: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
questionText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
Val (Map Text Text)
raw
    QuestionDate Text
questionText ->
        case Key (Map Text Text) -> Map Text Text -> Maybe (Val (Map Text Text))
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
lookup Text
Key (Map Text Text)
questionText Map Text Text
params of
            Maybe (Val (Map Text Text))
Nothing -> 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
$ Text
"Missing required field: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
questionText
            Just Val (Map Text Text)
raw
                | Text -> Bool
isValidDate Text
Val (Map Text Text)
raw -> (Key, Value) -> Either Text (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 -> 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
$ Text
"Invalid date format for: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
questionText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Expected YYYY-MM-DD"
    QuestionTime Text
questionText ->
        case Key (Map Text Text) -> Map Text Text -> Maybe (Val (Map Text Text))
forall t. StaticMap t => Key t -> t -> Maybe (Val t)
lookup Text
Key (Map Text Text)
questionText Map Text Text
params of
            Maybe (Val (Map Text Text))
Nothing -> 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
$ Text
"Missing required field: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
questionText
            Just Val (Map Text Text)
raw
                | Text -> Bool
isValidTime Text
Val (Map Text Text)
raw -> (Key, Value) -> Either Text (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 -> 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
$ Text
"Invalid time format for: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
questionText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Expected HH:MM"

validateBounds :: Text -> Integer -> QuestionOptions -> Either Text ()
validateBounds :: Text -> Integer -> QuestionOptions -> Either Text ()
validateBounds Text
questionText Integer
n QuestionOptions{Maybe Integer
lowerBoundInclusive :: QuestionOptions -> Maybe Integer
lowerBoundInclusive :: Maybe Integer
lowerBoundInclusive, Maybe Integer
upperBoundInclusive :: QuestionOptions -> Maybe Integer
upperBoundInclusive :: Maybe Integer
upperBoundInclusive} = do
    case Maybe Integer
lowerBoundInclusive of
        Just Integer
lb | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
lb -> Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text
questionText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": value " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall b a. (Show a, IsString b) => a -> b
show Integer
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is below minimum " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall b a. (Show a, IsString b) => a -> b
show Integer
lb
        Maybe Integer
_ -> () -> Either Text ()
forall a b. b -> Either a b
Right ()
    case Maybe Integer
upperBoundInclusive of
        Just Integer
ub | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
ub -> Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ Text
questionText Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": value " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall b a. (Show a, IsString b) => a -> b
show Integer
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is above maximum " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Integer -> Text
forall b a. (Show a, IsString b) => a -> b
show Integer
ub
        Maybe Integer
_ -> () -> Either Text ()
forall a b. b -> Either a b
Right ()

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