devforms 0.2.1.0 → 0.3.0.0

raw patch · 6 files changed

+108/−70 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• devforms.cabal +2/−2
• examples/Example.hs +1/−0
• src/BoundedNumber.hs +15/−0
• src/DevForms.hs +34/−6
• src/ParsedInteger.hs +0/−24
• src/Question.hs +56/−38

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

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

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

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

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

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