digestive-functors 0.7.1.5 → 0.8.4.2
raw patch · 11 files changed
Files
- CHANGELOG +34/−0
- digestive-functors.cabal +47/−34
- src/Text/Digestive/Form.hs +162/−42
- src/Text/Digestive/Form/Encoding.hs +11/−3
- src/Text/Digestive/Form/Internal.hs +5/−5
- src/Text/Digestive/Form/Internal/Field.hs +35/−28
- src/Text/Digestive/Types.hs +4/−2
- src/Text/Digestive/View.hs +15/−15
- tests/Text/Digestive/Form/QTests.hs +3/−1
- tests/Text/Digestive/Tests/Fixtures.hs +25/−13
- tests/Text/Digestive/View/Tests.hs +20/−14
CHANGELOG view
@@ -1,3 +1,37 @@+- 0.8.4.2 (2020-05-09)+ * Bump `Cabal` lower bound to 1.10++- 0.8.4.1 (2020-05-09)+ * Bump `semigroups` dependency upper bound to 0.20++- 0.8.4.0 (2017-07-18)+ * GHC 8.4 support+ * Bump `containers` to 0.6+ * Bump `time` to 1.9+ * Bump `QuickCheck` to 2.11++- 0.8.3.0 (2017-12-26)+ * Fix input element values for choice forms+ * Bump `time` to 1.8+ * Bump `HUnit` to 1.6+ * Bump `QuickCheck` to 2.10++- 0.8.2.0+ * Update `QuickCheck` version bound+ * Updated CHoice type to allow for multiple choices++- 0.8.1.1+ * Bump `time` dependency to allow up to `time-1.6`++- 0.8.1.0+ * Add support for a list of files via `<input type="file" multiple />`++- 0.8.0.1+ * Bump `HUnit` dependency to allow up to `HUnit-1.3`++- 0.8.0.0+ * Lots of constraint changes due to Applicative => Monad+ - 0.7.1.5 * Bump `time` dependency to allow up to `time-1.5`, for tests as well * Bump `QuickCheck` dependency to allow up to `QuickCheck-2.8`
digestive-functors.cabal view
@@ -1,5 +1,5 @@ Name: digestive-functors-Version: 0.7.1.5+Version: 0.8.4.2 Synopsis: A practical formlet library Description:@@ -39,14 +39,16 @@ Maintainer: Jasper Van der Jeugt <m@jaspervdj.be> Category: Web Build-type: Simple-Cabal-version: >= 1.8+Cabal-version: >= 1.10 Extra-source-files: CHANGELOG Library- Hs-source-dirs: src- Ghc-options: -Wall -fwarn-tabs+ Default-language: Haskell2010+ Hs-source-dirs: src+ Ghc-options: -Wall -fwarn-tabs+ Default-extensions: CPP Exposed-modules: Text.Digestive@@ -61,46 +63,57 @@ Text.Digestive.Form.Internal.Field Build-depends:- base >= 4 && < 5,- bytestring >= 0.9 && < 0.11,- containers >= 0.3 && < 0.6,- mtl >= 1.1.0.0 && < 3,- old-locale >= 1.0 && < 1.1,- text >= 0.10 && < 1.3,- time >= 1.4 && < 1.6- Extensions: CPP+ base >= 4 && < 5,+ bytestring >= 0.9 && < 0.11,+ containers >= 0.3 && < 0.7,+ mtl >= 1.1.0.0 && < 3,+ old-locale >= 1.0 && < 1.1,+ semigroups >= 0.16 && < 0.20,+ text >= 0.10 && < 1.3,+ time >= 1.4 && < 1.10 Test-suite digestive-functors-tests- Type: exitcode-stdio-1.0- Hs-source-dirs: src tests- Main-is: TestSuite.hs- Ghc-options: -Wall+ Default-language: Haskell2010+ Type: exitcode-stdio-1.0+ Hs-source-dirs: src tests+ Main-is: TestSuite.hs+ Ghc-options: -Wall Other-modules:- Text.Digestive.Field.Tests- Text.Digestive.Field.QTests- Text.Digestive.Form.Encoding.Tests- Text.Digestive.Form.Encoding.QTests- Text.Digestive.Form.List.QTests- Text.Digestive.Form.QTests- Text.Digestive.Tests.Fixtures- Text.Digestive.View.Tests- Text.Digestive.Types.QTests+ Text.Digestive.Field.QTests+ Text.Digestive.Field.Tests+ Text.Digestive.Form+ Text.Digestive.Form.Encoding+ Text.Digestive.Form.Encoding.QTests+ Text.Digestive.Form.Encoding.Tests+ Text.Digestive.Form.Internal+ Text.Digestive.Form.Internal.Field+ Text.Digestive.Form.List+ Text.Digestive.Form.List.QTests+ Text.Digestive.Form.QTests+ Text.Digestive.Ref+ Text.Digestive.Tests.Fixtures+ Text.Digestive.Types+ Text.Digestive.Types.QTests+ Text.Digestive.Util+ Text.Digestive.View+ Text.Digestive.View.Tests Build-depends:- HUnit >= 1.2 && < 1.3,- QuickCheck >= 2.5 && < 2.9,+ HUnit >= 1.2 && < 1.7,+ QuickCheck >= 2.5 && < 2.12, test-framework >= 0.4 && < 0.9, test-framework-hunit >= 0.3 && < 0.4, test-framework-quickcheck2 >= 0.3 && < 0.4, -- Copied from regular dependencies:- base >= 4 && < 5,- bytestring >= 0.9 && < 0.11,- containers >= 0.3 && < 0.6,- mtl >= 1.1.0.0 && < 3,- old-locale >= 1.0 && < 1.1,- text >= 0.10 && < 1.3,- time >= 1.4 && < 1.6+ base >= 4 && < 5,+ bytestring >= 0.9 && < 0.11,+ containers >= 0.3 && < 0.7,+ mtl >= 1.1.0.0 && < 3,+ old-locale >= 1.0 && < 1.1,+ semigroups >= 0.16 && < 0.19,+ text >= 0.10 && < 1.3,+ time >= 1.4 && < 1.10 Source-repository head Type: git
src/Text/Digestive/Form.hs view
@@ -1,9 +1,9 @@ --------------------------------------------------------------------------------+{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-}-{-# LANGUAGE CPP #-} -- | End-user interface - provides the main functionality for -- form creation and validation. For an interface for front-end -- implementation, see "View".@@ -21,12 +21,21 @@ , choice' , choiceWith , choiceWith'+ , choiceMultiple+ , choiceMultiple'+ , choiceWithMultiple+ , choiceWithMultiple' , groupedChoice , groupedChoice' , groupedChoiceWith , groupedChoiceWith'+ , groupedChoiceMultiple+ , groupedChoiceMultiple'+ , groupedChoiceWithMultiple+ , groupedChoiceWithMultiple' , bool , file+ , fileMultiple -- * Optional forms , optionalText@@ -64,13 +73,15 @@ import Control.Applicative import Control.Monad (liftM, liftM2) import Data.List (findIndex)-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, listToMaybe, catMaybes)+import Data.Monoid (Monoid) import Data.Text (Text) import qualified Data.Text as T import Data.Time #if !MIN_VERSION_time(1,5,0) import System.Locale #endif+import Prelude --------------------------------------------------------------------------------@@ -89,33 +100,33 @@ -------------------------------------------------------------------------------- -- | Returns a 'Formlet' which may optionally take a default text-text :: Formlet v m Text+text :: (Monad m, Monoid v) => Formlet v m Text text def = Pure $ Text $ fromMaybe "" def -------------------------------------------------------------------------------- -- | Identical to "text" but takes a String-string :: Monad m => Formlet v m String+string :: (Monad m, Monoid v) => Formlet v m String string = fmap T.unpack . text . fmap T.pack -------------------------------------------------------------------------------- -- | Returns a 'Formlet' for a parseable and serializable value type-stringRead :: (Monad m, Read a, Show a) => v -> Formlet v m a+stringRead :: (Monad m, Monoid v, Read a, Show a) => v -> Formlet v m a stringRead err = transform (readTransform err) . string . fmap show ----------------------------------------------------------------------------------- | Returns a 'Formlet' for a value restricted to+-- | Returns a 'Formlet' for a value restricted to a single value from -- the provided list of value-message tuples-choice :: (Eq a, Monad m) => [(a, v)] -> Formlet v m a+choice :: (Eq a, Monad m, Monoid v) => [(a, v)] -> Formlet v m a choice items def = choiceWith (zip makeRefs items) def -------------------------------------------------------------------------------- -- | Sometimes there is no good 'Eq' instance for 'choice'. In this case, you -- can use this function, which takes an index in the list as default.-choice' :: Monad m => [(a, v)] -> Maybe Int -> Form v m a+choice' :: (Monad m, Monoid v) => [(a, v)] -> Maybe Int -> Form v m a choice' items def = choiceWith' (zip makeRefs items) def @@ -124,7 +135,8 @@ -- resulting HTML instead of the default @[0 ..]@. This fixes some race -- conditions that might otherwise appear, e.g. if new choice items are added to -- some database while a user views and submits the form...-choiceWith :: (Eq a, Monad m) => [(Text, (a, v))] -> Formlet v m a+choiceWith+ :: (Eq a, Monad m, Monoid v) => [(Text, (a, v))] -> Formlet v m a choiceWith items def = choiceWith' items def' where def' = def >>= (\d -> findIndex ((== d) . fst . snd) items)@@ -132,15 +144,55 @@ -------------------------------------------------------------------------------- -- | A version of 'choiceWith' for when there is no good 'Eq' instance.-choiceWith' :: Monad m => [(Text, (a, v))] -> Maybe Int -> Form v m a-choiceWith' items def = fmap fst $ Pure $ Choice [("", items)] def'+choiceWith'+ :: (Monad m, Monoid v) => [(Text, (a, v))] -> Maybe Int -> Form v m a+choiceWith' [] _ = error "choice expects a list with at least one item in it"+choiceWith' items def = fromMaybe defaultItem . listToMaybe . map fst <$> (Pure $ Choice [("", items)] [def']) where+ defaultItem = fst $ snd $ items !! def' def' = fromMaybe 0 def ----------------------------------------------------------------------------------- | Returns a 'Formlet' for named groups of choices.-groupedChoice :: (Eq a, Monad m) => [(Text, [(a, v)])] -> Formlet v m a+-- | Returns a 'Formlet' for a value restricted to multiple values from+-- the provided list of value-message tuples. Intended for use with the+-- @multiple@ attribute for select elements. Allows for an empty result.+choiceMultiple :: (Eq a, Monad m, Monoid v) => [(a, v)] -> Formlet v m [a]+choiceMultiple items def = choiceWithMultiple (zip makeRefs items) def+++--------------------------------------------------------------------------------+-- | Sometimes there is no good 'Eq' instance for 'choice'. In this case, you+-- can use this function, which takes an index in the list as default.+choiceMultiple' :: (Monad m, Monoid v) => [(a, v)] -> Maybe [Int] -> Form v m [a]+choiceMultiple' items def = choiceWithMultiple' (zip makeRefs items) def+++--------------------------------------------------------------------------------+-- | Allows you to assign your own values: these values will be used in the+-- resulting HTML instead of the default @[0 ..]@. This fixes some race+-- conditions that might otherwise appear, e.g. if new choice items are added to+-- some database while a user views and submits the form...+choiceWithMultiple+ :: (Eq a, Monad m, Monoid v) => [(Text, (a, v))] -> Formlet v m [a]+choiceWithMultiple items def = choiceWithMultiple' items def'+ where+ def' = def >>= Just . catMaybes . map (\d -> findIndex ((== d) . fst . snd) items)+++--------------------------------------------------------------------------------+-- | A version of 'choiceWithMultiple' for when there is no good 'Eq' instance.+choiceWithMultiple'+ :: (Monad m, Monoid v) => [(Text, (a, v))] -> Maybe [Int] -> Form v m [a]+choiceWithMultiple' items def = map fst <$> (Pure $ Choice [("", items)] def')+ where+ def' = fromMaybe [] def+++--------------------------------------------------------------------------------+-- | Returns a 'Formlet' for a single value from named groups of choices.+groupedChoice+ :: (Eq a, Monad m, Monoid v) => [(Text, [(a, v)])] -> Formlet v m a groupedChoice items def = groupedChoiceWith (mkGroupedRefs items makeRefs) def @@ -148,11 +200,13 @@ -------------------------------------------------------------------------------- -- | Sometimes there is no good 'Eq' instance for 'choice'. In this case, you -- can use this function, which takes an index in the list as default.-groupedChoice' :: Monad m => [(Text, [(a, v)])] -> Maybe Int -> Form v m a+groupedChoice'+ :: (Monad m, Monoid v) => [(Text, [(a, v)])] -> Maybe Int -> Form v m a groupedChoice' items def = groupedChoiceWith' (mkGroupedRefs items makeRefs) def +-------------------------------------------------------------------------------- mkGroupedRefs :: [(Text, [a])] -> [Text] -> [(Text, [(Text, a)])]@@ -168,7 +222,7 @@ -- resulting HTML instead of the default @[0 ..]@. This fixes some race -- conditions that might otherwise appear, e.g. if new choice items are added to -- some database while a user views and submits the form...-groupedChoiceWith :: (Eq a, Monad m)+groupedChoiceWith :: (Eq a, Monad m, Monoid v) => [(Text, [(Text, (a, v))])] -> Formlet v m a groupedChoiceWith items def = groupedChoiceWith' items def'@@ -179,34 +233,92 @@ -------------------------------------------------------------------------------- -- | Low-level support for grouped choice.-groupedChoiceWith' :: Monad m+groupedChoiceWith' :: (Monad m, Monoid v) => [(Text, [(Text, (a, v))])] -> Maybe Int -> Form v m a-groupedChoiceWith' items def = fmap fst $ Pure $ Choice items def'+groupedChoiceWith' items def =+ case concatMap snd items of+ [] -> error "groupedChoice expects a list with at least one item in it"+ _ -> head . map fst <$> (Pure $ Choice items def') where- def' = fromMaybe 0 def+ def' = case def of+ Just x -> [x]+ Nothing -> [0] --------------------------------------------------------------------------------+-- | Returns a 'Formlet' for multiple values from named groups of choices.+-- Intended for use with the @multiple@ attribute for select elements that+-- have optgroups. Allows for an empty result.+groupedChoiceMultiple+ :: (Eq a, Monad m, Monoid v) => [(Text, [(a, v)])] -> Formlet v m [a]+groupedChoiceMultiple items def =+ groupedChoiceWithMultiple (mkGroupedRefs items makeRefs) def+++--------------------------------------------------------------------------------+-- | Sometimes there is no good 'Eq' instance for 'choice'. In this case, you+-- can use this function, which takes an index in the list as default.+groupedChoiceMultiple'+ :: (Monad m, Monoid v) => [(Text, [(a, v)])] -> Maybe [Int] -> Form v m [a]+groupedChoiceMultiple' items def =+ groupedChoiceWithMultiple' (mkGroupedRefs items makeRefs) def+++--------------------------------------------------------------------------------+-- | Allows you to assign your own values: these values will be used in the+-- resulting HTML instead of the default @[0 ..]@. This fixes some race+-- conditions that might otherwise appear, e.g. if new choice items are added to+-- some database while a user views and submits the form...+groupedChoiceWithMultiple :: (Eq a, Monad m, Monoid v)+ => [(Text, [(Text, (a, v))])]+ -> Formlet v m [a]+groupedChoiceWithMultiple items def = groupedChoiceWithMultiple' items def'+ where+ def' = def >>= Just . catMaybes . map (\d -> findIndex ((== d) . fst . snd) $+ concat $ map snd items)+++--------------------------------------------------------------------------------+-- | Low-level support for grouped choice.+groupedChoiceWithMultiple' :: (Monad m, Monoid v)+ => [(Text, [(Text, (a, v))])]+ -> Maybe [Int]+ -> Form v m [a]+groupedChoiceWithMultiple' items def = map fst <$> (Pure $ Choice items def')+ where+ def' = case def of+ Just x -> x+ Nothing -> []++-------------------------------------------------------------------------------- -- | Returns a 'Formlet' for binary choices-bool :: Formlet v m Bool+bool :: (Monad m, Monoid v) => Formlet v m Bool bool = Pure . Bool . fromMaybe False -------------------------------------------------------------------------------- -- | Returns a 'Formlet' for file selection-file :: Form v m (Maybe FilePath)-file = Pure File+file :: (Monad m, Monoid v) => Form v m (Maybe FilePath)+file = listToMaybe <$> Pure File --------------------------------------------------------------------------------+-- | Returns a 'Formlet' for multiple file selection. Intended for use with+-- the @multiple@ attribute, which allows for multiple files to be uploaded+-- with a single input element.+fileMultiple :: (Monad m, Monoid v) => Form v m [FilePath]+fileMultiple = Pure File+++-------------------------------------------------------------------------------- -- | Validate the results of a form with a simple predicate -- -- Example: -- -- > check "Can't be empty" (not . null) (string Nothing)-check :: Monad m+check :: (Monad m, Monoid v) => v -- ^ Error message (if fail) -> (a -> Bool) -- ^ Validating predicate -> Form v m a -- ^ Form to validate@@ -216,7 +328,7 @@ -------------------------------------------------------------------------------- -- | Version of 'check' which allows monadic validations-checkM :: Monad m => v -> (a -> m Bool) -> Form v m a -> Form v m a+checkM :: (Monad m, Monoid v) => v -> (a -> m Bool) -> Form v m a -> Form v m a checkM err predicate form = validateM f form where f x = do@@ -236,14 +348,14 @@ -- > -- > char :: Monad m => Form m String Char -- > char = validate head' (string Nothing)-validate :: Monad m => (a -> Result v b) -> Form v m a -> Form v m b+validate :: (Monad m, Monoid v) => (a -> Result v b) -> Form v m a -> Form v m b validate = validateM . (return .) -------------------------------------------------------------------------------- -- | Same as 'validate', but works with forms of the form: -- -- > Form v m (Maybe a)--- +-- -- . -- -- Example: taking the first character of an optional input string@@ -254,19 +366,22 @@ -- > -- > char :: Monad m => Form m String (Maybe Char) -- > char = validateOptional head' (optionalString Nothing)-validateOptional :: Monad m => (a -> Result v b) -> Form v m (Maybe a) -> Form v m (Maybe b)+validateOptional+ :: (Monad m, Monoid v)+ => (a -> Result v b) -> Form v m (Maybe a) -> Form v m (Maybe b) validateOptional f = validate (forOptional f) -------------------------------------------------------------------------------- -- | Version of 'validate' which allows monadic validations-validateM :: Monad m => (a -> m (Result v b)) -> Form v m a -> Form v m b+validateM+ :: (Monad m, Monoid v) => (a -> m (Result v b)) -> Form v m a -> Form v m b validateM = transform -------------------------------------------------------------------------------- -- | Allows for the composition of independent validation functions. -- -- For example, let's validate an even integer between 0 and 100:--- +-- -- > form :: Monad m => Form Text m FormData -- > ... -- some fields -- > <*> "smallEvenInteger" .: validate (notEmpty >=> integer >=> even >=> greaterThan 0 >=> lessThanOrEq 100) (text Nothing)@@ -282,17 +397,17 @@ -- -- . ----- This will validate our smallEvenInteger correctly, but there is a problem. +-- This will validate our smallEvenInteger correctly, but there is a problem. -- If a user enters an odd number greater than 100, only -- -- > "number must be even" -- ----- will be returned. It would make for a better user experience if +-- will be returned. It would make for a better user experience if -- -- > ["number must be even", "number must be less than 100"] ----- was returned instead. This can be accomplished by rewriting our form to be: +-- was returned instead. This can be accomplished by rewriting our form to be: -- -- > form :: Monad m => Form [Text] m FormData -- > ... -- some fields@@ -302,7 +417,7 @@ -- . -- -- If we want to collapse our list of errors into a single 'Text', we can do something like:--- +-- -- > form :: Monad m => Form Text m FormData -- > ... -- some fields -- > <*> "smallEvenInteger" .: validate (notEmpty >=> integer >=> commaSeperated . conditions [even, greaterThan 0, lessThanOrEq 100]) (text Nothing)@@ -319,7 +434,7 @@ -- -- > conditions [even, greaterThan 0] -1 --- -- is specified to return + -- is specified to return -- -- > Error ["must be even", "must be greater than 0"] --@@ -348,7 +463,7 @@ -- | Create a text form with an optional default text which -- returns nothing if no optional text was set, and no input -- was retrieved.-optionalText :: Monad m => Maybe Text -> Form v m (Maybe Text)+optionalText :: (Monad m, Monoid v) => Maybe Text -> Form v m (Maybe Text) optionalText def = validate opt (text def) where opt t@@ -358,13 +473,13 @@ -------------------------------------------------------------------------------- -- | Identical to 'optionalText', but uses Strings-optionalString :: Monad m => Maybe String -> Form v m (Maybe String)+optionalString :: (Monad m, Monoid v) => Maybe String -> Form v m (Maybe String) optionalString = fmap (fmap T.unpack) . optionalText . fmap T.pack -------------------------------------------------------------------------------- -- | Identical to 'optionalText' for parseable and serializable values.-optionalStringRead :: (Monad m, Read a, Show a)+optionalStringRead :: (Monad m, Monoid v, Read a, Show a) => v -> Maybe a -> Form v m (Maybe a) optionalStringRead err = transform readTransform' . optionalString . fmap show where@@ -374,17 +489,22 @@ -------------------------------------------------------------------------------- -- Helper function for attempted parsing, with custom error messages-readTransform :: (Monad m, Read a) => v -> String -> m (Result v a)+readTransform :: (Monad m, Monoid v, Read a) => v -> String -> m (Result v a) readTransform err = return . maybe (Error err) return . readMaybe ----------------------------------------------------------------------------------- | Dynamic lists-listOf :: Monad m- => Formlet v m a- -> Formlet v m [a]+-- | Dynamic lists.+--+-- The type is a less restrictive version of:+--+-- > Formlet a -> Formlet [a]+listOf :: (Monad m, Monoid v)+ => (Maybe a -> Form v m b)+ -> (Maybe [a] -> Form v m [b]) listOf single def = List (fmap single defList) (indicesRef .: listIndices ixs)+ where ixs = case def of Nothing -> [0]@@ -395,7 +515,7 @@ -------------------------------------------------------------------------------- -- Manipulatable indices-listIndices :: Monad m => [Int] -> Form v m [Int]+listIndices :: (Monad m, Monoid v) => [Int] -> Form v m [Int] listIndices = fmap parseIndices . text . Just . unparseIndices
src/Text/Digestive/Form/Encoding.hs view
@@ -13,6 +13,7 @@ import Control.Monad.Identity (Identity) import Data.Maybe (mapMaybe) import Data.Monoid (Monoid (..), mconcat)+import Data.Semigroup (Semigroup (..)) --------------------------------------------------------------------------------@@ -37,12 +38,19 @@ --------------------------------------------------------------------------------+-- Semigroup instance for encoding types: prefer UrlEncoded, but fallback to+-- MultiPart when needed+instance Semigroup FormEncType where+ UrlEncoded <> x = x+ MultiPart <> _ = MultiPart+++-------------------------------------------------------------------------------- -- Monoid instance for encoding types: prefer UrlEncoded, but fallback to -- MultiPart when needed instance Monoid FormEncType where- mempty = UrlEncoded- mappend UrlEncoded x = x- mappend MultiPart _ = MultiPart+ mempty = UrlEncoded+ mappend = (<>) --------------------------------------------------------------------------------
src/Text/Digestive/Form/Internal.hs view
@@ -97,7 +97,7 @@ ---------------------------------------------------------------------------------instance Monad m => Functor (FormTree t v m) where+instance (Monad m, Monoid v) => Functor (FormTree t v m) where fmap = transform . (return .) . (return .) @@ -157,7 +157,7 @@ -------------------------------------------------------------------------------- -- | Map on the value type-transform :: Monad m+transform :: (Monad m, Monoid v) => (a -> m (Result v b)) -> FormTree t v m a -> FormTree t v m b transform f (Map g x) = Map (\y -> g y `bindResult` f) x transform f x = Map f x@@ -392,11 +392,11 @@ Just x' -> case (f x') of Success x'' -> Success (Just x'') Error x'' -> Error x''- + -------------------------------------------------------------------------------- -- | Utility: bind for 'Result' inside another monad-bindResult :: Monad m+bindResult :: (Monad m, Monoid v) => m (Result v a) -> (a -> m (Result v b)) -> m (Result v b)@@ -409,7 +409,7 @@ -------------------------------------------------------------------------------- -- | Debugging purposes-debugFormPaths :: Monad m => FormTree Identity v m a -> [Path]+debugFormPaths :: (Monad m, Monoid v) => FormTree Identity v m a -> [Path] debugFormPaths (Pure _) = [[]] debugFormPaths (App x y) = debugFormPaths x ++ debugFormPaths y debugFormPaths (Map _ x) = debugFormPaths x
src/Text/Digestive/Form/Internal/Field.hs view
@@ -14,7 +14,9 @@ -------------------------------------------------------------------------------- import Control.Arrow (second)-import Data.Maybe (fromMaybe, listToMaybe)+import Data.Maybe (listToMaybe, mapMaybe, catMaybes)+import Data.Functor ((<$>))+import Data.List (findIndex) import Data.Text (Text) @@ -27,12 +29,12 @@ data Field v a where Singleton :: a -> Field v a Text :: Text -> Field v Text- -- A list of identifier, value, view. Then we have the default index in- -- the list. The return value has the actual value as well as the index in- -- the list.- Choice :: [(Text, [(Text, (a, v))])] -> Int -> Field v (a, Int)+ -- A list of (group name, [(identifier, (value, view))]).+ -- Then we have the default index in the list.+ -- The return value has the actual value as well as the index in the list.+ Choice :: [(Text, [(Text, (a, v))])] -> [Int] -> Field v [(a, Int)] Bool :: Bool -> Field v Bool- File :: Field v (Maybe FilePath)+ File :: Field v [FilePath] --------------------------------------------------------------------------------@@ -59,22 +61,24 @@ evalField _ _ (Singleton x) = x evalField _ (TextInput x : _) (Text _) = x evalField _ _ (Text x) = x-evalField _ (TextInput x : _) (Choice ls' y) =- let ls = concat (map snd ls') in- fromMaybe (fst (snd (ls !! y)), y) $ do- -- Expects input in the form of "foo.bar.2". This is not needed for- -- <select> fields, but we need it for labels for radio buttons.- t <- listToMaybe $ reverse $ toPath x- (c, i) <- lookupIdx t ls- return (fst c, i)-evalField _ _ (Choice ls' x) =- let ls = concat (map snd ls') in- (fst (snd (ls !! x)), x)+evalField _ ts@(TextInput _ : _) (Choice ls _) =+ let ls' = concat (map snd ls) in+ catMaybes $+ map (\(TextInput x) ->+ (\i -> (fst $ snd $ ls' !! i, i)) <$> findIndex (isSelectedChoice x . fst) ls') ts+evalField Get _ (Choice ls x) =+ -- this populates the default values when displaying a view+ let ls' = concat (map snd ls) in+ map (\i -> (fst $ snd $ ls' !! i, i)) x+evalField Post _ (Choice _ _) = [] evalField Get _ (Bool x) = x evalField Post (TextInput x : _) (Bool _) = x == "on" evalField Post _ (Bool _) = False-evalField Post (FileInput x : _) File = Just x-evalField _ _ File = Nothing+evalField Post xs File = mapMaybe maybeFile xs+ where+ maybeFile (FileInput x) = Just x+ maybeFile _ = Nothing+evalField _ _ File = [] --------------------------------------------------------------------------------@@ -89,12 +93,15 @@ ----------------------------------------------------------------------------------- | Retrieve the value and position of the value referenced to by the given--- key in an association list, if the key is in the list.-lookupIdx :: Eq k => k -> [(k, v)] -> Maybe (v, Int)-lookupIdx key = go 0- where- go _ [] = Nothing- go !i ((k, v) : xs)- | key == k = Just (v, i)- | otherwise = go (i + 1) xs+-- | Determines if the choiceVal is equal to the selectedVal. Works with older+-- versions that submit "foo.bar.2" rather than "2" for Choice fields.+-- > isSelectedChoice "0" "0" == True+-- > isSelectedChoice "foo.bar.0" "0" == True+-- > isSelectedChoice "foo.bar.10" "0" == False+isSelectedChoice :: Text -> Text -> Bool+isSelectedChoice selectedVal choiceVal+ | selectedVal == choiceVal = True+ | otherwise =+ case listToMaybe (reverse $ toPath selectedVal) of+ Just x -> x == choiceVal+ _ -> False
src/Text/Digestive/Types.hs view
@@ -1,4 +1,6 @@ --------------------------------------------------------------------------------+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -- | Core types used internally module Text.Digestive.Types@@ -14,7 +16,7 @@ ---------------------------------------------------------------------------------import Control.Applicative (Applicative(..))+import Control.Applicative (Applicative (..)) import Data.Monoid (Monoid, mappend) @@ -48,7 +50,7 @@ ---------------------------------------------------------------------------------instance Monad (Result v) where+instance Monoid v => Monad (Result v) where return x = Success x (Error x) >>= _ = Error x (Success x) >>= f = f x
src/Text/Digestive/View.hs view
@@ -57,6 +57,7 @@ import Control.Arrow (second) import Control.Monad.Identity (Identity) import Data.List (isPrefixOf)+import Data.Monoid (Monoid) import Data.Text (Text) import qualified Data.Text as T @@ -73,12 +74,12 @@ -- | Finalized form - handles the form, error messages and input. -- Internally handles the addressing of individual fields. data View v = forall a m. Monad m => View- { viewName :: Text- , viewContext :: Path- , viewForm :: FormTree Identity v m a- , viewInput :: [(Path, FormInput)]- , viewErrors :: [(Path, v)]- , viewMethod :: Method+ { viewName :: Text+ , viewContext :: Path+ , viewForm :: FormTree Identity v m a+ , viewInput :: [(Path, FormInput)]+ , viewErrors :: [(Path, v)]+ , viewMethod :: Method } @@ -204,13 +205,12 @@ eval' :: Field v b -> [(Text, v, Bool)] eval' field = case field of Choice xs didx ->- let idx = snd $ evalField method givenInput (Choice xs didx)- in map (\(i, (k, (_, v))) -> (k, v, i == idx)) $+ let idx = map snd $ evalField method givenInput (Choice xs didx)+ in map (\(i, (k, (_, v))) -> (k, v, i `elem` idx)) $ zip [0 ..] $ concat $ map snd xs f -> error $ T.unpack ref ++ ": expected (Choice _ _), " ++ "but got: (" ++ show f ++ ")" - -------------------------------------------------------------------------------- -- | Returns a list of (groupName, [(identifier, view, selected?)]) fieldInputChoiceGroup :: forall v. Text@@ -225,12 +225,12 @@ eval' :: Field v b -> [(Text, [(Text, v, Bool)])] eval' field = case field of Choice xs didx ->- let idx = snd $ evalField method givenInput (Choice xs didx)+ let idx = map snd $ evalField method givenInput (Choice xs didx) in merge idx xs [0..] f -> error $ T.unpack ref ++ ": expected (Choice _ _), " ++ "but got: (" ++ show f ++ ")" -merge :: Int+merge :: [Int] -> [(Text, [(Text, (a, v))])] -> [Int] -> [(Text, [(Text, v, Bool)])]@@ -238,7 +238,7 @@ merge idx (g:gs) is = cur : merge idx gs b where (a,b) = splitAt (length $ snd g) is- cur = (fst g, map (\(i, (k, (_, v))) -> (k, v, i == idx)) $ zip a (snd g))+ cur = (fst g, map (\(i, (k, (_, v))) -> (k, v, i `elem` idx)) $ zip a (snd g)) -------------------------------------------------------------------------------- -- | Returns True/False based on the field referred to by the given@@ -259,14 +259,14 @@ -------------------------------------------------------------------------------- -- | Return the FilePath referred to by the given serialized path, if set.-fieldInputFile :: forall v. Text -> View v -> Maybe FilePath+fieldInputFile :: forall v. Text -> View v -> [FilePath] fieldInputFile ref (View _ _ form input _ method) = queryField path form eval' where path = toPath ref givenInput = lookupInput path input - eval' :: Field v b -> Maybe FilePath+ eval' :: Field v b -> [FilePath] eval' field = case field of File -> evalField method givenInput File f -> error $ T.unpack ref ++ ": expected (File), " ++@@ -333,5 +333,5 @@ -------------------------------------------------------------------------------- -- | Retrieve all paths of the contained form-debugViewPaths :: View v -> [Path]+debugViewPaths :: Monoid v => View v -> [Path] debugViewPaths (View _ _ form _ _ _) = debugFormPaths form
tests/Text/Digestive/Form/QTests.hs view
@@ -22,8 +22,10 @@ import Control.Monad import Control.Monad.Identity import Data.Maybe+import Data.Monoid (Monoid) import Data.Text (Text, pack) + -------------------------------------------------------------------------------- tests :: Test@@ -65,7 +67,7 @@ -------------------------------------------------------------------------------- -- Limited arbitrary instance for form trees-instance (Monad t, Monad m, Arbitrary a) => Arbitrary (FormTree t v m a)+instance (Monad t, Monad m, Monoid v, Arbitrary a) => Arbitrary (FormTree t v m a) where arbitrary = sized (innerarb $ liftM Pure arbitrary) where innerarb g 0 = g innerarb g n = innerarb g' (n-1)
tests/Text/Digestive/Tests/Fixtures.hs view
@@ -59,21 +59,32 @@ ---------------------------------------------------------------------------------data Type = Water | Fire | Leaf+data Type = Water | Fire | Leaf | Rock deriving (Eq, Show) --------------------------------------------------------------------------------+typeChoices :: [(Type, Text)]+typeChoices = [(Water, "Water"), (Fire, "Fire"), (Leaf, "Leaf"), (Rock, "Rock")]+++-------------------------------------------------------------------------------- typeForm :: Monad m => Form Text m Type-typeForm = choice [(Water, "Water"), (Fire, "Fire"), (Leaf, "Leaf")] Nothing+typeForm = choice typeChoices Nothing --------------------------------------------------------------------------------+weaknessForm :: Monad m => Form Text m [Type]+weaknessForm = choiceMultiple typeChoices Nothing+++-------------------------------------------------------------------------------- data Pokemon = Pokemon- { pokemonName :: Text- , pokemonLevel :: Maybe Int- , pokemonType :: Type- , pokemonRare :: Bool+ { pokemonName :: Text+ , pokemonLevel :: Maybe Int+ , pokemonType :: Type+ , pokemonWeakness :: [Type]+ , pokemonRare :: Bool } deriving (Eq, Show) @@ -93,10 +104,11 @@ -------------------------------------------------------------------------------- pokemonForm :: Form Text TrainerM Pokemon pokemonForm = Pokemon- <$> "name" .: validate isPokemon (text Nothing)- <*> "level" .: levelForm- <*> "type" .: typeForm- <*> "rare" .: bool Nothing+ <$> "name" .: validate isPokemon (text Nothing)+ <*> "level" .: levelForm+ <*> "type" .: typeForm+ <*> "weakness" .: weaknessForm+ <*> "rare" .: bool Nothing where definitelyNoPokemon = ["dog", "cat"] isPokemon name@@ -176,9 +188,9 @@ -------------------------------------------------------------------------------- canCatch :: Catch -> Bool-canCatch (Catch (Pokemon _ _ _ False) _) = True-canCatch (Catch (Pokemon _ _ _ True) Ultra) = True-canCatch (Catch (Pokemon _ _ _ True) Master) = True+canCatch (Catch (Pokemon _ _ _ _ False) _) = True+canCatch (Catch (Pokemon _ _ _ _ True) Ultra) = True+canCatch (Catch (Pokemon _ _ _ _ True) Master) = True canCatch _ = False
tests/Text/Digestive/View/Tests.hs view
@@ -33,18 +33,22 @@ tests :: Test tests = testGroup "Text.Digestive.View.Tests" [ testCase "Simple postForm" $ (@=?)- (Just (Pokemon "charmander" (Just 5) Fire False)) $+ (Just (Pokemon "charmander" (Just 5) Fire [Water, Rock] False)) $ snd $ runTrainerM $ postForm "f" pokemonForm $ testEnv- [ ("f.name", "charmander")- , ("f.level", "5")- , ("f.type", "type.1")+ [ ("f.name", "charmander")+ , ("f.level", "5")+ , ("f.type", "type.1")+ , ("f.weakness", "0") -- NOTE: this is the newer style of Choice values+ , ("f.weakness", "3") ] , testCase "optional unspecified" $ (@=?)- (Just (Pokemon "magmar" Nothing Fire False)) $+ (Just (Pokemon "magmar" Nothing Fire [Water, Rock] False)) $ snd $ runTrainerM $ postForm "f" pokemonForm $ testEnv- [ ("f.name", "magmar")- , ("f.type", "type.1")+ [ ("f.name", "magmar")+ , ("f.type", "type.1")+ , ("f.weakness", "weakness.0") -- NOTE: this is the older style of Choice values+ , ("f.weakness", "weakness.3") ] , testCase "stringRead float" $ (@=?)@@ -91,12 +95,14 @@ postForm "f" pokemonForm $ testEnv [("f.type", "type.2")] , testCase "Nested postForm" $ (@=?)- (Just (Catch (Pokemon "charmander" (Just 5) Fire False) Ultra)) $+ (Just (Catch (Pokemon "charmander" (Just 5) Fire [Water, Rock] False) Ultra)) $ snd $ runTrainerM $ postForm "f" catchForm $ testEnv- [ ("f.pokemon.name", "charmander")- , ("f.pokemon.level", "5")- , ("f.pokemon.type", "type.1")- , ("f.ball", "ball.2")+ [ ("f.pokemon.name", "charmander")+ , ("f.pokemon.level", "5")+ , ("f.pokemon.type", "type.1")+ , ("f.pokemon.weakness", "weakness.0")+ , ("f.pokemon.weakness", "weakness.3")+ , ("f.ball", "ball.2") ] , testCase "subView errors" $ (@=?)@@ -118,11 +124,11 @@ ] , testCase "subViews length" $ (@=?)- 4 $+ 5 $ length $ subViews $ runTrainerM $ getForm "f" pokemonForm , testCase "subViews after subView length" $ (@=?)- 4 $+ 5 $ length $ subViews $ subView "pokemon" $ runTrainerM $ getForm "f" catchForm