Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Add experimental choiceWith and a test

See #38
  • Loading branch information...
commit 0a2e201cd328822f93fda69841a2466814a052b6 1 parent 0af1d12
@jaspervdj authored
View
12 digestive-functors/src/Text/Digestive/Form.hs
@@ -15,6 +15,7 @@ module Text.Digestive.Form
, stringRead
, choice
, choice'
+ , choiceWith
, bool
, file
@@ -79,10 +80,15 @@ choice items def = choice' items $
-- | 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' items def = fmap fst $ Pure Nothing $ Choice items' def'
+choice' items def = choiceWith (zip makeRefs items) def
+
+
+--------------------------------------------------------------------------------
+-- | Experimental
+choiceWith :: Monad m => [(Text, (a, v))] -> Maybe Int -> Form v m a
+choiceWith items def = fmap fst $ Pure Nothing $ Choice items def'
where
- items' = zip makeRefs items
- def' = fromMaybe 0 def
+ def' = fromMaybe 0 def
--------------------------------------------------------------------------------
View
98 digestive-functors/tests/Text/Digestive/Tests/Fixtures.hs
@@ -1,6 +1,8 @@
+--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
module Text.Digestive.Tests.Fixtures
- ( TrainerM
+ ( -- * Pokemon!
+ TrainerM
, runTrainerM
, Type (..)
, Pokemon (..)
@@ -9,31 +11,54 @@ module Text.Digestive.Tests.Fixtures
, ballForm
, Catch (..)
, catchForm
+
+ -- * Store/product
+ , Database
+ , runDatabase
+ , Product (..)
+ , productForm
+ , Order (..)
+ , orderForm
+
+ -- * Various
, floatForm
) where
-import Control.Applicative ((<$>), (<*>))
-import Control.Monad.Reader (Reader, ask, runReader)
-import Data.Text (Text)
-import qualified Data.Text as T
+--------------------------------------------------------------------------------
+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
-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
@@ -41,6 +66,8 @@ data Pokemon = Pokemon
, pokemonRare :: Bool
} deriving (Eq, Show)
+
+--------------------------------------------------------------------------------
levelForm :: Form Text TrainerM (Maybe Int)
levelForm =
checkM "This pokemon will not obey you!" checkMaxLevel $
@@ -52,6 +79,8 @@ levelForm =
maxLevel <- ask
return $ l <= maxLevel
+
+--------------------------------------------------------------------------------
pokemonForm :: Form Text TrainerM Pokemon
pokemonForm = Pokemon
<$> "name" .: validate isPokemon (text Nothing)
@@ -65,29 +94,84 @@ pokemonForm = Pokemon
| 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
+ [ Product "s9_ao" "Sector 9 Agent Orange"
+ , Product "ew_br" "Earthwing Belly Racer"
+ , Product "cm_gs" "Comet Grease Shark"
+ ]
+
+
+--------------------------------------------------------------------------------
+data Product = Product
+ { productId :: Text
+ , productName :: Text
+ } deriving (Eq, Show)
+
+
+--------------------------------------------------------------------------------
+productForm :: Form Text Database Product
+productForm = monadic $ do
+ products <- ask
+ return $ choiceWith (map makeChoice products) Nothing
+ where
+ makeChoice p = (productId p, (p, productName p))
+
+
+--------------------------------------------------------------------------------
+data Order = Order
+ { orderProduct :: Product
+ , orderQuantity :: Int
+ } deriving (Eq, Show)
+
+
+--------------------------------------------------------------------------------
+orderForm :: Form Text Database Order
+orderForm = Order
+ <$> "product" .: productForm
+ <*> "quantity" .: stringRead "Can't parse" Nothing
+
+
+--------------------------------------------------------------------------------
floatForm :: Monad m => Form Text m Float
floatForm = "f" .: stringRead "Can't parse float" Nothing
View
10 digestive-functors/tests/Text/Digestive/View/Tests.hs
@@ -14,6 +14,7 @@ import Test.HUnit (Assertion, assert, assertFailure, (@=?))
import Text.Digestive.Tests.Fixtures
import Text.Digestive.Types
import Text.Digestive.View
+import Text.Digestive.Form.Internal
assertError :: Show a => a -> Assertion
assertError x = handle (\(_ :: SomeException) -> assert True) $
@@ -93,6 +94,15 @@ tests = testGroup "Text.Digestive.View.Tests"
, testCase "Abusing Text as Bool" $ assertError $
fieldInputBool "name" $ runTrainerM $ getForm "f" pokemonForm
+
+ , testCase "cURL submit" $ (@=?)
+ (Just (Order (Product "cm_gs" "Comet Grease Shark") 2)) $
+ snd $ runDatabase $ postForm "f" orderForm $ 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")
+ ]
]
testEnv :: Monad m => [(Text, Text)] -> Env m
Please sign in to comment.
Something went wrong with that request. Please try again.