digestive-functors 0.8.1.1 → 0.8.2.0

raw patch · 7 files changed

+181/−57 lines, 7 filesdep ~HUnitdep ~QuickCheckPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: HUnit, QuickCheck

API changes (from Hackage documentation)

Files

• CHANGELOG +4/−0
• digestive-functors.cabal +3/−3
• src/Text/Digestive/Form.hs +107/−7
• src/Text/Digestive/Form/Internal/Field.hs +17/−14
• src/Text/Digestive/View.hs +5/−6
• tests/Text/Digestive/Tests/Fixtures.hs +25/−13
• tests/Text/Digestive/View/Tests.hs +20/−14

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

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

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

@@ -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         -- <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)+        t <- listToMaybe . reverse $ toPath x+        (c, i) <- lookupIdx t ls'+        return (fst c, i)) 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

@@ -205,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@@ -226,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)])]@@ -239,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

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

@@ -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", "weakness.0")+            , ("f.weakness", "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")+            , ("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