diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,7 @@ +- 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` diff --git a/digestive-functors.cabal b/digestive-functors.cabal --- a/digestive-functors.cabal +++ b/digestive-functors.cabal @@ -1,5 +1,5 @@ Name: digestive-functors -Version: 0.8.1.1 +Version: 0.8.2.0 Synopsis: A practical formlet library Description: @@ -88,8 +88,8 @@ Text.Digestive.Types.QTests Build-depends: - HUnit >= 1.2 && < 1.4, - QuickCheck >= 2.5 && < 2.9, + HUnit >= 1.2 && < 1.6, + QuickCheck >= 2.5 && < 2.10, test-framework >= 0.4 && < 0.9, test-framework-hunit >= 0.3 && < 0.4, test-framework-quickcheck2 >= 0.3 && < 0.4, diff --git a/src/Text/Digestive/Form.hs b/src/Text/Digestive/Form.hs --- a/src/Text/Digestive/Form.hs +++ b/src/Text/Digestive/Form.hs @@ -21,10 +21,18 @@ , choice' , choiceWith , choiceWith' + , choiceMultiple + , choiceMultiple' + , choiceWithMultiple + , choiceWithMultiple' , groupedChoice , groupedChoice' , groupedChoiceWith , groupedChoiceWith' + , groupedChoiceMultiple + , groupedChoiceMultiple' + , groupedChoiceWithMultiple + , groupedChoiceWithMultiple' , bool , file , fileMultiple @@ -65,7 +73,7 @@ import Control.Applicative import Control.Monad (liftM, liftM2) import Data.List (findIndex) -import Data.Maybe (fromMaybe, listToMaybe) +import Data.Maybe (fromMaybe, listToMaybe, catMaybes) import Data.Monoid (Monoid) import Data.Text (Text) import qualified Data.Text as T @@ -108,7 +116,7 @@ -------------------------------------------------------------------------------- --- | 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, Monoid v) => [(a, v)] -> Formlet v m a choice items def = choiceWith (zip makeRefs items) def @@ -137,13 +145,55 @@ -- | A version of 'choiceWith' for when there is no good 'Eq' instance. choiceWith' :: (Monad m, Monoid v) => [(Text, (a, v))] -> Maybe Int -> Form v m a -choiceWith' items def = fmap fst $ Pure $ Choice [("", items)] def' +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 - def' = fromMaybe 0 def + defaultItem = fst $ snd $ head items + def' = case def of + Just x -> [x] + Nothing -> [0] -------------------------------------------------------------------------------- --- | Returns a 'Formlet' for named groups of choices. +-- | 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' = case def of + Just x -> x + Nothing -> [] + + +-------------------------------------------------------------------------------- +-- | 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 = @@ -190,10 +240,60 @@ => [(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 diff --git a/src/Text/Digestive/Form/Internal/Field.hs b/src/Text/Digestive/Form/Internal/Field.hs --- a/src/Text/Digestive/Form/Internal/Field.hs +++ b/src/Text/Digestive/Form/Internal/Field.hs @@ -14,7 +14,7 @@ -------------------------------------------------------------------------------- import Control.Arrow (second) -import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Data.Maybe (listToMaybe, mapMaybe, catMaybes) import Data.Text (Text) @@ -27,10 +27,10 @@ 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 [FilePath] @@ -59,17 +59,20 @@ 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 +evalField _ ts@(TextInput _ : _) (Choice ls _) = + let ls' = concat (map snd ls) in + catMaybes $ + map (\(TextInput x) -> do -- Expects input in the form of "foo.bar.2". This is not needed for --