digestive-functors 0.6.0.0 → 0.6.0.1
raw patch · 5 files changed
+453/−1 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- digestive-functors.cabal +6/−1
- tests/Text/Digestive/Field/Tests.hs +36/−0
- tests/Text/Digestive/Form/Encoding/Tests.hs +34/−0
- tests/Text/Digestive/Tests/Fixtures.hs +200/−0
- tests/Text/Digestive/View/Tests.hs +177/−0
digestive-functors.cabal view
@@ -1,5 +1,5 @@ Name: digestive-functors-Version: 0.6.0.0+Version: 0.6.0.1 Synopsis: A practical formlet library Description:@@ -68,6 +68,11 @@ Type: exitcode-stdio-1.0 Hs-source-dirs: src tests Main-is: TestSuite.hs+ Other-modules:+ Text.Digestive.Field.Tests+ Text.Digestive.Form.Encoding.Tests+ Text.Digestive.Tests.Fixtures+ Text.Digestive.View.Tests Ghc-options: -Wall Build-depends:
+ tests/Text/Digestive/Field/Tests.hs view
@@ -0,0 +1,36 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Text.Digestive.Field.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?))+++--------------------------------------------------------------------------------+import Text.Digestive.Form.Internal.Field+import Text.Digestive.Types+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Text.Digestive.Field.Tests"+ [ testCase "evalField singleton" $+ 9160 @=? evalField undefined undefined (Singleton (9160 :: Int))++ , testCase "evalField bool post without input" $+ False @=? evalField Post [] (Bool True)++ , testCase "evalField bool post strange input" $+ False @=? evalField Post [TextInput "herp"] (Bool True)++ , testCase "evalField bool post correct input" $+ True @=? evalField Post [TextInput "on"] (Bool True)++ , testCase "evalField bool get" $+ True @=? evalField Get [] (Bool True)+ ]
+ tests/Text/Digestive/Form/Encoding/Tests.hs view
@@ -0,0 +1,34 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Text.Digestive.Form.Encoding.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Control.Applicative ((<$>), (<*>))+import Control.Monad.Identity (Identity(..))+import Data.Text (Text)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?))+++--------------------------------------------------------------------------------+import Text.Digestive.Form+import Text.Digestive.Form.Encoding+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Text.Digestive.Field.Tests"+ [ testCase "formEncType url-encoded" $+ UrlEncoded @=? formEncType' ((,) <$> text Nothing <*> bool Nothing)+ , testCase "formEncType multipart" $+ MultiPart @=? formEncType' ((,) <$> text Nothing <*> file)+ , testCase "formEncType multipart" $+ MultiPart @=? formEncType' ((,) <$> file <*> bool Nothing)+ ]+ where+ formEncType' :: Form Text Identity a -> FormEncType+ formEncType' = runIdentity . formEncType
+ tests/Text/Digestive/Tests/Fixtures.hs view
@@ -0,0 +1,200 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Text.Digestive.Tests.Fixtures+ ( -- * Pokemon!+ TrainerM+ , runTrainerM+ , Type (..)+ , Pokemon (..)+ , pokemonForm+ , Ball (..)+ , ballForm+ , Catch (..)+ , catchForm++ -- * Store/product+ , Database+ , runDatabase+ , sector9+ , earthwing+ , comet+ , Product (..)+ , productForm+ , Order (..)+ , orderForm+ , ordersForm++ -- * Various+ , floatForm+ ) where+++--------------------------------------------------------------------------------+import Control.Applicative ((<$>), (<*>))+import Control.Monad.Reader (Reader, ask, runReader)+import Data.Text (Text)+import qualified Data.Text as T+++--------------------------------------------------------------------------------+import Text.Digestive.Form+import Text.Digestive.Types+++--------------------------------------------------------------------------------+-- Maximum level+type TrainerM = Reader Int+++--------------------------------------------------------------------------------+-- Default max level: 20+runTrainerM :: TrainerM a -> a+runTrainerM = flip runReader 20+++--------------------------------------------------------------------------------+data Type = Water | Fire | Leaf+ deriving (Eq, Show)+++--------------------------------------------------------------------------------+typeForm :: Monad m => Form Text m Type+typeForm = choice [(Water, "Water"), (Fire, "Fire"), (Leaf, "Leaf")] Nothing+++--------------------------------------------------------------------------------+data Pokemon = Pokemon+ { pokemonName :: Text+ , pokemonLevel :: Maybe Int+ , pokemonType :: Type+ , pokemonRare :: Bool+ } deriving (Eq, Show)+++--------------------------------------------------------------------------------+levelForm :: Form Text TrainerM (Maybe Int)+levelForm =+ checkM "This pokemon will not obey you!" checkMaxLevel $+ check "Level should be at least 1" (maybe True (> 1)) $+ optionalStringRead "Cannot parse level" Nothing+ where+ checkMaxLevel Nothing = return True+ checkMaxLevel (Just l) = do+ maxLevel <- ask+ return $ l <= maxLevel+++--------------------------------------------------------------------------------+pokemonForm :: Form Text TrainerM Pokemon+pokemonForm = Pokemon+ <$> "name" .: validate isPokemon (text Nothing)+ <*> "level" .: levelForm+ <*> "type" .: typeForm+ <*> "rare" .: bool Nothing+ where+ definitelyNoPokemon = ["dog", "cat"]+ isPokemon name+ | name `notElem` definitelyNoPokemon = Success name+ | otherwise =+ Error $ name `T.append` " is not a pokemon!"+++--------------------------------------------------------------------------------+data Ball = Poke | Great | Ultra | Master+ deriving (Eq, Show)+++--------------------------------------------------------------------------------+ballForm :: Monad m => Form Text m Ball+ballForm = choice+ [(Poke, "Poke"), (Great, "Great"), (Ultra, "Ultra"), (Master, "Master")]+ Nothing+++--------------------------------------------------------------------------------+data Catch = Catch+ { catchPokemon :: Pokemon+ , catchBall :: Ball+ } deriving (Eq, Show)+++--------------------------------------------------------------------------------+catchForm :: Form Text TrainerM Catch+catchForm = check "You need a better ball" canCatch $ Catch+ <$> "pokemon" .: pokemonForm+ <*> "ball" .: ballForm+++--------------------------------------------------------------------------------+canCatch :: Catch -> Bool+canCatch (Catch (Pokemon _ _ _ False) _) = True+canCatch (Catch (Pokemon _ _ _ True) Ultra) = True+canCatch (Catch (Pokemon _ _ _ True) Master) = True+canCatch _ = False+++--------------------------------------------------------------------------------+type Database = Reader [Product]+++--------------------------------------------------------------------------------+runDatabase :: Database a -> a+runDatabase = flip runReader [sector9, earthwing, comet]+++--------------------------------------------------------------------------------+sector9 :: Product+sector9 = Product "s9_ao" "Sector 9 Agent Orange"+++--------------------------------------------------------------------------------+earthwing :: Product+earthwing = Product "ew_br" "Earthwing Belly Racer"+++--------------------------------------------------------------------------------+comet :: Product+comet = Product "cm_gs" "Comet Grease Shark"+++--------------------------------------------------------------------------------+data Product = Product+ { productId :: Text+ , productName :: Text+ } deriving (Eq, Show)+++--------------------------------------------------------------------------------+productForm :: Formlet Text Database Product+productForm def = monadic $ do+ products <- ask+ return $ choiceWith (map makeChoice products) def+ where+ makeChoice p = (productId p, (p, productName p))+++--------------------------------------------------------------------------------+data Order = Order+ { orderProduct :: Product+ , orderQuantity :: Int+ } deriving (Eq, Show)+++--------------------------------------------------------------------------------+orderForm :: Formlet Text Database Order+orderForm def = Order+ <$> "product" .: productForm (orderProduct <$> def)+ <*> "quantity" .: stringRead "Can't parse" (orderQuantity <$> def)+++--------------------------------------------------------------------------------+ordersForm :: Formlet Text Database (Text, [Order])+ordersForm def = (,)+ <$> "name" .: text (fst <$> def)+ -- id is here because of a regression+ <*> (id <$> "orders" .: listOf orderForm (snd <$> def))+++--------------------------------------------------------------------------------+floatForm :: Monad m => Form Text m Float+floatForm = "f" .: stringRead "Can't parse float" Nothing
+ tests/Text/Digestive/View/Tests.hs view
@@ -0,0 +1,177 @@+-------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Text.Digestive.View.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Control.Exception (SomeException, handle)+import Control.Monad.Identity (runIdentity)+import Data.Text (Text)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?), (@?=))+import qualified Test.HUnit as H+++--------------------------------------------------------------------------------+import Text.Digestive.Tests.Fixtures+import Text.Digestive.Types+import Text.Digestive.View+++--------------------------------------------------------------------------------+assertError :: Show a => a -> H.Assertion+assertError x = handle (\(_ :: SomeException) -> H.assert True) $+ x `seq` H.assertFailure $ "Should throw an error but gave: " ++ show x+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Text.Digestive.View.Tests"+ [ testCase "Simple postForm" $ (@=?)+ (Just (Pokemon "charmander" (Just 5) Fire False)) $+ snd $ runTrainerM $ postForm "f" pokemonForm $ testEnv+ [ ("f.name", "charmander")+ , ("f.level", "5")+ , ("f.type", "type.1")+ ]++ , testCase "optional unspecified" $ (@=?)+ (Just (Pokemon "magmar" Nothing Fire False)) $+ snd $ runTrainerM $ postForm "f" pokemonForm $ testEnv+ [ ("f.name", "magmar")+ , ("f.type", "type.1")+ ]++ , testCase "stringRead float" $ (@=?)+ (Just 4.323 :: Maybe Float) $+ snd $ runIdentity $ postForm "f" floatForm $ testEnv+ [("f.f", "4.323")]++ , testCase "Failing checkM" $ (@=?)+ ["This pokemon will not obey you!"] $+ childErrors "" $ fst $ runTrainerM $ postForm "f" pokemonForm $ testEnv+ [ ("f.name", "charmander")+ , ("f.level", "9000")+ , ("f.type", "type.1")+ ]++ , testCase "Failing validate" $ (@=?)+ ["dog is not a pokemon!"] $+ childErrors "" $ fst $ runTrainerM $ postForm "f" pokemonForm $ testEnv+ [("f.name", "dog")]++ , testCase "Simple fieldInputChoice" $ (@=?)+ "Leaf" $+ snd $ selection $ fieldInputChoice "type" $ fst $ runTrainerM $+ postForm "f" pokemonForm $ testEnv [("f.type", "type.2")]++ , testCase "Nested postForm" $ (@=?)+ (Just (Catch (Pokemon "charmander" (Just 5) Fire 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")+ ]++ , testCase "subView errors" $ (@=?)+ ["Cannot parse level"] $+ errors "level" $ subView "pokemon" $ fst $ runTrainerM $+ postForm "f" catchForm $ testEnv [("f.pokemon.level", "hah.")]++ , testCase "subView childErrors" $ (@=?)+ ["Cannot parse level"] $+ childErrors "" $ subView "pokemon" $ fst $ runTrainerM $+ postForm "f" catchForm $ testEnv [("f.pokemon.level", "hah.")]++ , testCase "subView input" $ (@=?)+ "Leaf" $+ snd $ selection $ fieldInputChoice "type" $ subView "pokemon" $ fst $+ runTrainerM $ postForm "f" catchForm $ testEnv+ [ ("f.pokemon.level", "hah.")+ , ("f.pokemon.type", "type.2")+ ]++ , testCase "subViews length" $ (@=?)+ 4 $+ length $ subViews $ runTrainerM $ getForm "f" pokemonForm++ , testCase "subViews after subView length" $ (@=?)+ 4 $+ length $ subViews $ subView "pokemon" $+ runTrainerM $ getForm "f" catchForm++ , testCase "Abusing Choice as Text" $ assertError $+ fieldInputText "type" $ runTrainerM $ getForm "f" pokemonForm++ , testCase "Abusing Bool as Choice" $ assertError $+ fieldInputChoice "rare" $ runTrainerM $ getForm "f" pokemonForm++ , testCase "Abusing Text as Bool" $ assertError $+ fieldInputBool "name" $ runTrainerM $ getForm "f" pokemonForm++ , testCase "monadic choiceWith" $ (@=?)+ (Just (Order comet 2)) $+ snd $ runDatabase $ postForm "f" (orderForm Nothing) $ testEnv+ -- We actually need f.product.cm_gs for the choice input, but this+ -- must work as well!+ [ ("f.product", "cm_gs")+ , ("f.quantity", "2")+ ]++ , testCase "monadic view query" $ (@=?)+ "Earthwing Belly Racer" $+ snd $ selection $ fieldInputChoice "product" $ runDatabase $+ getForm "f"+ -- With a default+ (orderForm $ Just $ Order earthwing 10)++ , -- Let me just order 3 awesome skateboards here+ testCase "Simple listOf" $ do+ let (view, result) = runDatabase $ postForm "f" (ordersForm Nothing) $+ testEnv+ [ ("f.name", "Jasper")+ {- \ /\ -} , ("f.orders.indices", "0,10")+ {- ) ( ') -} , ("f.orders.0.product", "cm_gs")+ {- ( / ) -} , ("f.orders.0.quantity", "2")+ {- \(__)| -} , ("f.orders.10.product", "s9_ao")+ , ("f.orders.10.quantity", "1")+ ]++ result @?= Just+ ( "Jasper"+ , [ Order (Product "cm_gs" "Comet Grease Shark") 2+ , Order (Product "s9_ao" "Sector 9 Agent Orange") 1+ ]+ )++ let subViews' = listSubViews "orders" view+ fieldInputText "quantity" (head subViews') @?= "2"++ , testCase "listOf with defaults" $ do+ let view = runDatabase $ getForm "f" $ ordersForm $ Just+ ( "Jasper"+ , [ Order comet 2+ , Order sector9 3+ ]+ )++ let subViews' = listSubViews "orders" view+ fst (selection (fieldInputChoice "product" (subViews' !! 1))) @=?+ "s9_ao"+ ]+++--------------------------------------------------------------------------------+testEnv :: Monad m => [(Text, Text)] -> Env m+testEnv input key = return $ map (TextInput . snd) $+ filter ((== fromPath key) . fst) input+++--------------------------------------------------------------------------------+selection :: [(Text, v, Bool)] -> (Text, v)+selection fic = head [(t, v) | (t, v, s) <- fic, s]