diff --git a/devforms.cabal b/devforms.cabal --- a/devforms.cabal +++ b/devforms.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: devforms -version: 0.2.1.0 +version: 0.3.0.0 synopsis: A builder DSL for HTML survey forms with built-in server and storage description: devforms is a Haskell library for building HTML survey forms using a @@ -33,7 +33,7 @@ other-modules: Server , Form , Question - , ParsedInteger + , BoundedNumber -- other-extensions: default-extensions: OverloadedStrings diff --git a/examples/Example.hs b/examples/Example.hs --- a/examples/Example.hs +++ b/examples/Example.hs @@ -35,6 +35,7 @@ questionDate "Select a date" questionIntegerWith "Enter a natural number" $ do setUpperBoundInclusive 15 + questionFloatWith "Enter a float" (pure ()) questionLikert "This form works well" questionTime "Select a time" questionFreeTextWith "Any special requests?" $ setOptional diff --git a/src/BoundedNumber.hs b/src/BoundedNumber.hs new file mode 100644 --- /dev/null +++ b/src/BoundedNumber.hs @@ -0,0 +1,15 @@ +module BoundedNumber (BoundedNumber, parseWithBounds, unwrapBounded, NumberBoundError (..)) +where + +data BoundedNumber a = BoundedNumber a + +data NumberBoundError = NumberOutOfBounds deriving (Show) + +parseWithBounds :: (Real a) => Maybe Double -> Maybe Double -> a -> Either NumberBoundError (BoundedNumber a) +parseWithBounds lb ub n = + let lowerBoundSatisfied = maybe True (\l -> toRational l <= (toRational n)) lb + upperBoundSatisfied = maybe True (\u -> toRational u >= (toRational n)) ub + in if lowerBoundSatisfied && upperBoundSatisfied then pure $ BoundedNumber n else Left NumberOutOfBounds + +unwrapBounded :: BoundedNumber a -> a +unwrapBounded (BoundedNumber n) = n diff --git a/src/DevForms.hs b/src/DevForms.hs --- a/src/DevForms.hs +++ b/src/DevForms.hs @@ -37,7 +37,7 @@ ServerBuilder, FormBuilder, QuestionBuilder, - IntegerQuestionBuilder, + NumberQuestionBuilder, MultiChoiceQuestionBuilder, HasOptional (..), HasBounds (..), @@ -58,6 +58,8 @@ questionTimeWith, questionInteger, questionIntegerWith, + questionFloat, + questionFloatWith, questionFreeText, questionFreeTextWith, questionRegexText, @@ -70,8 +72,9 @@ HasBounds (..), HasOptional (..), HasSelectionBounds (..), - IntegerQuestionBuilder, MultiChoiceQuestionBuilder, + NumberQuestionBuilder, + NumberType (..), Question (..), QuestionBuilder, QuestionType (..), @@ -240,7 +243,7 @@ questionInteger label = questionIntegerWith label (pure ()) {- | Add an integer input question with custom options. The second argument is -an 'IntegerQuestionBuilder' block where you can configure bounds using +a 'NumberQuestionBuilder' block where you can configure bounds using 'setLowerBoundInclusive' and 'setUpperBoundInclusive', as well as shared options like 'setOptional'. Bounds are enforced both client-side (via HTML attributes) and server-side on submission. @@ -254,9 +257,34 @@ setOptional @ -} -questionIntegerWith :: Text -> IntegerQuestionBuilder () -> FormBuilder () -questionIntegerWith title builder = - addQuestion $ Question title QuestionInteger (runIntegerQuestionBuilder builder) +questionIntegerWith :: Text -> NumberQuestionBuilder () -> FormBuilder () +questionIntegerWith = questionNumberWith NumberInteger + +-- | Add a float input question with default options (no bounds). +questionFloat :: Text -> FormBuilder () +questionFloat label = questionFloatWith label (pure ()) + +{- | Add a float input question with custom options. The second argument is +a 'NumberQuestionBuilder' block where you can configure bounds using +'setLowerBoundInclusive' and 'setUpperBoundInclusive', as well as shared +options like 'setOptional'. Bounds are enforced both client-side (via HTML +attributes) and server-side on submission. + +=== Example + +@ +questionFloatWith "How many pets do you have?" $ do + setLowerBoundInclusive 0 + setUpperBoundInclusive 50 + setOptional +@ +-} +questionFloatWith :: Text -> NumberQuestionBuilder () -> FormBuilder () +questionFloatWith = questionNumberWith NumberFloat + +questionNumberWith :: NumberType -> Text -> NumberQuestionBuilder () -> FormBuilder () +questionNumberWith numberType title builder = + addQuestion $ Question title (QuestionNumber numberType) (runIntegerQuestionBuilder builder) {- | Add a free-text textarea question with default options. The respondent can enter arbitrary text. diff --git a/src/ParsedInteger.hs b/src/ParsedInteger.hs deleted file mode 100644 --- a/src/ParsedInteger.hs +++ /dev/null @@ -1,24 +0,0 @@ -module ParsedInteger (ParsedInteger, parseWithBounds, parsedToInteger, IntegerBoundError (..)) -where - -newtype ParsedInteger = ParsedInteger Integer - -data IntegerBoundError = IntegerOutOfBounds deriving (Show) - -parseWithBounds :: Maybe Integer -> Maybe Integer -> Integer -> Either IntegerBoundError ParsedInteger -parseWithBounds (Just lowerBoundInclusive) (Just upperBoundInclusive) n = - if lowerBoundInclusive <= n && upperBoundInclusive >= n - then pure $ ParsedInteger n - else Left IntegerOutOfBounds -parseWithBounds (Just lowerBoundInclusive) Nothing n = - if lowerBoundInclusive <= n - then pure $ ParsedInteger n - else Left IntegerOutOfBounds -parseWithBounds Nothing (Just upperBoundInclusive) n = - if upperBoundInclusive >= n - then pure $ ParsedInteger n - else Left IntegerOutOfBounds -parseWithBounds Nothing Nothing n = Right $ ParsedInteger n - -parsedToInteger :: ParsedInteger -> Integer -parsedToInteger (ParsedInteger n) = n diff --git a/src/Question.hs b/src/Question.hs --- a/src/Question.hs +++ b/src/Question.hs @@ -5,8 +5,9 @@ Question (..), QuestionType (..), QuestionOptions (..), + NumberType (..), QuestionBuilder, - IntegerQuestionBuilder, + NumberQuestionBuilder, MultiChoiceQuestionBuilder, HasOptional (..), HasBounds (..), @@ -19,13 +20,13 @@ parseAnswers, ) where +import BoundedNumber 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 ((=~)) @@ -36,12 +37,12 @@ } deriving (Show) -data QuestionType = QuestionCheckbox | QuestionLikert | QuestionChoice [Text] | QuestionMultiChoice [Text] | QuestionDate | QuestionInteger | QuestionTime | QuestionFreeText | QuestionRegexText Text deriving (Show) +data QuestionType = QuestionCheckbox | QuestionLikert | QuestionChoice [Text] | QuestionMultiChoice [Text] | QuestionDate | QuestionNumber NumberType | QuestionTime | QuestionFreeText | QuestionRegexText Text deriving (Show) data QuestionOptions = QuestionOptions { isOptional :: Bool - , lowerBoundInclusive :: Maybe Integer - , upperBoundInclusive :: Maybe Integer + , lowerBoundInclusive :: Maybe Double + , upperBoundInclusive :: Maybe Double , minSelections :: Maybe Int , maxSelections :: Maybe Int } @@ -50,12 +51,14 @@ defaultOptions :: QuestionOptions defaultOptions = QuestionOptions{isOptional = False, lowerBoundInclusive = Nothing, upperBoundInclusive = Nothing, minSelections = Nothing, maxSelections = Nothing} +data NumberType = NumberInteger | NumberFloat deriving (Show, Eq) + -- | 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) +newtype NumberQuestionBuilder a = NumberQuestionBuilder (Writer (Endo QuestionOptions) a) deriving newtype (Functor, Applicative, Monad) -- | A builder monad for configuring multi-choice question options (selection bounds and optionality). @@ -68,8 +71,8 @@ -- | Typeclass for builders that support setting numeric bounds. class HasBounds m where - setLowerBoundInclusive :: Integer -> m - setUpperBoundInclusive :: Integer -> m + setLowerBoundInclusive :: Double -> m + setUpperBoundInclusive :: Double -> m -- | Typeclass for builders that support setting selection count bounds. class HasSelectionBounds m where @@ -79,12 +82,12 @@ 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 HasOptional (NumberQuestionBuilder ()) where + setOptional = NumberQuestionBuilder $ 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 HasBounds (NumberQuestionBuilder ()) where + setLowerBoundInclusive bound = NumberQuestionBuilder $ tell $ Endo $ \o -> o{lowerBoundInclusive = Just bound} + setUpperBoundInclusive bound = NumberQuestionBuilder $ tell $ Endo $ \o -> o{upperBoundInclusive = Just bound} instance HasOptional (MultiChoiceQuestionBuilder ()) where setOptional = MultiChoiceQuestionBuilder $ tell $ Endo $ \o -> o{isOptional = True} @@ -93,15 +96,15 @@ 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) +data AnswerError = NoRegexMatch Text | MissingRequiredField Text | InvalidTimeFormatFor Text | InvalidDateFormatFor Text | InvalidLikertOptionFor Text | InvalidChoiceFor Text | InvalidNumberFor Text NumberBoundError | NumberParseErrorFor 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 an 'NumberQuestionBuilder' to extract the configured 'QuestionOptions'. +runIntegerQuestionBuilder :: NumberQuestionBuilder () -> QuestionOptions +runIntegerQuestionBuilder (NumberQuestionBuilder w) = appEndo (execWriter w) defaultOptions -- | Run a 'MultiChoiceQuestionBuilder' to extract the configured 'QuestionOptions'. runMultiChoiceQuestionBuilder :: MultiChoiceQuestionBuilder () -> QuestionOptions @@ -229,14 +232,17 @@ label_ [Lucid.for_ (qId <> "-" <> c)] $ toHtml c QuestionDate -> do input_ $ [type_ "date", name_ questionText, ariaErrormessage_ errId] <> requiredAttrs - QuestionInteger -> do + QuestionNumber numberType -> do let QuestionOptions{lowerBoundInclusive = lowerBound, upperBoundInclusive = upperBound} = questionOptions let validationScriptParts = - [ [__i| - on input - set my.value to my.value.replace('/[^0-9-]/g', '') - end - |] + [ case numberType of + NumberInteger -> + [__i| + on input + set my.value to my.value.replace('/[^0-9-]/g', '') + end + |] + NumberFloat -> "" , runJust "" lowerBound @@ -268,17 +274,20 @@ 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 - ] + [ type_ "number" + , name_ questionText + , case numberType of + NumberInteger -> pattern_ "[0-9]+" + NumberFloat -> pattern_ "[0-9.]+" + , case numberType of + NumberInteger -> step_ "1" + NumberFloat -> step_ "any" + , script_ validationScript + , ariaErrormessage_ errId + , id_ "integer" + ] + <> (maybeToList $ fmap (min_ . show) lowerBound) + <> (maybeToList $ fmap (max_ . show) upperBound) <> requiredAttrs QuestionLikert -> do let radioScript = @@ -347,16 +356,25 @@ QuestionCheckbox -> let value = JSON.Bool $ isJust $ Map.lookup questionText params' in Right (Key.fromText questionText, value) - QuestionInteger -> do + QuestionNumber numberType -> 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)) + let validate :: (Real a) => Maybe a -> Either AnswerError (BoundedNumber a) + validate parsed = do + n <- maybeToRight (NumberParseErrorFor questionText) parsed + boundsCheckedNumber <- mapLeft (InvalidNumberFor questionText) $ parseWithBounds lowerBound upperBound n + pure boundsCheckedNumber + case numberType of + NumberInteger -> do + validated <- validate (readMaybe (toString raw) :: Maybe Integer) + pure (Key.fromText questionText, JSON.toJSON (unwrapBounded validated)) + NumberFloat -> do + validated <- validate (readMaybe (toString raw) :: Maybe Float) + pure (Key.fromText questionText, JSON.toJSON (unwrapBounded validated)) QuestionChoice choices -> case Map.lookup questionText params' of Nothing