diff --git a/Text/Digestive/Blaze/Html5.hs b/Text/Digestive/Blaze/Html5.hs
index 29aba93..9b2d9f3 100644
--- a/Text/Digestive/Blaze/Html5.hs
+++ b/Text/Digestive/Blaze/Html5.hs
@@ -23,6 +23,8 @@ import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import Text.Digestive.Types
+import Text.Digestive.Http (HttpInput (..))
+import qualified Text.Digestive.Http as Http
import qualified Text.Digestive.Common as Common
import Text.Digestive.Html
@@ -45,22 +47,22 @@ checked :: Bool -> Html -> Html
checked False x = x
checked True x = x ! A.checked "checked"
-inputText :: (Monad m, Functor m)
+inputText :: (Monad m, Functor m, HttpInput i)
=> Maybe String
- -> Form m String e BlazeFormHtml String
-inputText = Common.inputString $ \id' inp -> createFormHtml $ \cfg ->
+ -> Form m i e BlazeFormHtml String
+inputText = Http.inputString $ \id' inp -> createFormHtml $ \cfg ->
applyClasses' [htmlInputClasses] cfg $
H.input ! A.type_ "text"
! A.name (H.stringValue $ show id')
! A.id (H.stringValue $ show id')
! A.value (H.stringValue $ fromMaybe "" inp)
-inputTextArea :: (Monad m, Functor m)
- => Maybe Int -- ^ Rows
- -> Maybe Int -- ^ Columns
- -> Maybe String -- ^ Default input
- -> Form m String e BlazeFormHtml String -- ^ Result
-inputTextArea r c = Common.inputString $ \id' inp -> createFormHtml $ \cfg ->
+inputTextArea :: (Monad m, Functor m, HttpInput i)
+ => Maybe Int -- ^ Rows
+ -> Maybe Int -- ^ Columns
+ -> Maybe String -- ^ Default input
+ -> Form m i e BlazeFormHtml String -- ^ Result
+inputTextArea r c = Http.inputString $ \id' inp -> createFormHtml $ \cfg ->
applyClasses' [htmlInputClasses] cfg $ rows r $ cols c $
H.textarea ! A.name (H.stringValue $ show id')
! A.id (H.stringValue $ show id')
@@ -71,41 +73,41 @@ inputTextArea r c = Common.inputString $ \id' inp -> createFormHtml $ \cfg ->
cols Nothing = id
cols (Just x) = (! A.cols (H.stringValue $ show x))
-inputTextRead :: (Monad m, Functor m, Show a, Read a)
+inputTextRead :: (Monad m, Functor m, HttpInput i, Show a, Read a)
=> e
-> Maybe a
- -> Form m String e BlazeFormHtml a
-inputTextRead error' = flip Common.inputRead error' $ \id' inp ->
+ -> Form m i e BlazeFormHtml a
+inputTextRead error' = flip Http.inputRead error' $ \id' inp ->
createFormHtml $ \cfg -> applyClasses' [htmlInputClasses] cfg $
H.input ! A.type_ "text"
! A.name (H.stringValue $ show id')
! A.id (H.stringValue $ show id')
! A.value (H.stringValue $ fromMaybe "" inp)
-inputPassword :: (Monad m, Functor m)
- => Form m String e BlazeFormHtml String
-inputPassword = flip Common.inputString Nothing $ \id' inp ->
+inputPassword :: (Monad m, Functor m, HttpInput i)
+ => Form m i e BlazeFormHtml String
+inputPassword = flip Http.inputString Nothing $ \id' inp ->
createFormHtml $ \cfg -> applyClasses' [htmlInputClasses] cfg $
H.input ! A.type_ "password"
! A.name (H.stringValue $ show id')
! A.id (H.stringValue $ show id')
! A.value (H.stringValue $ fromMaybe "" inp)
-inputCheckBox :: (Monad m, Functor m)
+inputCheckBox :: (Monad m, Functor m, HttpInput i)
=> Bool
- -> Form m String e BlazeFormHtml Bool
-inputCheckBox inp = flip Common.inputBool inp $ \id' inp' ->
+ -> Form m i e BlazeFormHtml Bool
+inputCheckBox inp = flip Http.inputBool inp $ \id' inp' ->
createFormHtml $ \cfg -> applyClasses' [htmlInputClasses] cfg $
checked inp' $ H.input ! A.type_ "checkbox"
! A.name (H.stringValue $ show id')
! A.id (H.stringValue $ show id')
-inputRadio :: (Monad m, Functor m, Eq a)
- => Bool -- ^ Use @
@ tags
- -> a -- ^ Default option
- -> [(a, Html)] -- ^ Choices with their names
- -> Form m String e BlazeFormHtml a -- ^ Resulting form
-inputRadio br def choices = Common.inputChoice toView def (map fst choices)
+inputRadio :: (Monad m, Functor m, HttpInput i, Eq a)
+ => Bool -- ^ Use @
@ tags
+ -> a -- ^ Default option
+ -> [(a, Html)] -- ^ Choices with their names
+ -> Form m i e BlazeFormHtml a -- ^ Resulting form
+inputRadio br def choices = Http.inputChoice toView def (map fst choices)
where
toView group id' sel val = createFormHtml $ \cfg -> do
applyClasses' [htmlInputClasses] cfg $ checked sel $
diff --git a/Text/Digestive/Common.hs b/Text/Digestive/Common.hs
index 72d8a02..dbce204 100644
--- a/Text/Digestive/Common.hs
+++ b/Text/Digestive/Common.hs
@@ -2,24 +2,15 @@
--
module Text.Digestive.Common
( input
- , inputString
- , inputRead
- , inputBool
- , inputChoice
, label
, errors
, childErrors
) where
-import Control.Applicative ((<$>))
-import Control.Monad (mplus)
-import Data.Monoid (Monoid, mconcat)
-import Data.Maybe (fromMaybe)
-
import Text.Digestive.Types
import Text.Digestive.Result
-import Text.Digestive.Transform
+-- TODO: Check parameter usage
input :: (Monad m, Functor m)
=> (Bool -> Maybe i -> d -> s) -- ^ Get the viewed result
-> (Maybe i -> FormRange -> Result e a) -- ^ Get the returned result
@@ -35,51 +26,6 @@ input toView toResult createView defaultInput = Form $ do
result' = toResult inp range
return (View (const $ createView id' view'), result')
-inputString :: (Monad m, Functor m)
- => (FormId -> Maybe String -> v) -- ^ View constructor
- -> Maybe String -- ^ Default value
- -> Form m String e v String -- ^ Resulting form
-inputString = input toView toResult
- where
- toView = const mplus
- toResult = const . Ok . fromMaybe ""
-
-inputRead :: (Monad m, Functor m, Read a, Show a)
- => (FormId -> Maybe String -> v) -- ^ View constructor
- -> e -- ^ Error when no read
- -> Maybe a -- ^ Default input
- -> Form m String e v a -- ^ Resulting form
-inputRead cons' error' def = inputString cons' (fmap show def)
- `transform` transformRead error'
-
-inputBool :: (Monad m, Functor m)
- => (FormId -> Bool -> v) -- ^ View constructor
- -> Bool -- ^ Default input
- -> Form m String e v Bool -- ^ Resulting form
-inputBool = input toView toResult
- where
- toView isInput inp def = if isInput then readBool inp else def
- toResult inp _ = Ok $ readBool inp
- readBool (Just x) = not (null x)
- readBool Nothing = False
-
-inputChoice :: (Monad m, Functor m, Monoid v, Eq a)
- => (FormId -> String -> Bool -> a -> v) -- ^ Choice constructor
- -> a -- ^ Default option
- -> [a] -- ^ Choices
- -> Form m String e v a -- ^ Resulting form
-inputChoice toView defaultInput choices = Form $ do
- inputKey <- fromMaybe "" <$> getFormInput
- id' <- getFormId
- let -- Find the actual input, based on the key, or use the default input
- inp = fromMaybe defaultInput $ lookup inputKey $ zip (ids id') choices
- -- Apply the toView' function to all choices
- view' = mconcat $ zipWith (toView' id' inp) (ids id') choices
- return (View (const view'), Ok inp)
- where
- ids id' = map (((show id' ++ "-") ++) . show) [1 .. length choices]
- toView' id' inp key x = toView id' key (inp == x) x
-
label :: Monad m
=> (FormId -> v)
-> Form m i e v ()
diff --git a/Text/Digestive/Http.hs b/Text/Digestive/Http.hs
new file mode 100644
index 0000000..7968dbd
--- /dev/null
+++ b/Text/Digestive/Http.hs
@@ -0,0 +1,65 @@
+module Text.Digestive.Http
+ ( HttpInput (..)
+ , inputString
+ , inputRead
+ , inputBool
+ , inputChoice
+ ) where
+
+import Control.Applicative ((<$>))
+import Control.Monad (mplus)
+import Data.Monoid (Monoid, mconcat)
+import Data.Maybe (fromMaybe)
+
+import Text.Digestive.Common
+import Text.Digestive.Types
+import Text.Digestive.Result
+import Text.Digestive.Transform
+
+class HttpInput a where
+ getInputString :: a -> String
+
+inputString :: (Monad m, Functor m, HttpInput i)
+ => (FormId -> Maybe String -> v) -- ^ View constructor
+ -> Maybe String -- ^ Default value
+ -> Form m i e v String -- ^ Resulting form
+inputString = input toView toResult
+ where
+ toView _ inp defaultInput = fmap getInputString inp `mplus` defaultInput
+ toResult = const . Ok . fromMaybe "" . fmap getInputString
+
+inputRead :: (Monad m, Functor m, HttpInput i, Read a, Show a)
+ => (FormId -> Maybe String -> v) -- ^ View constructor
+ -> e -- ^ Error when no read
+ -> Maybe a -- ^ Default input
+ -> Form m i e v a -- ^ Resulting form
+inputRead cons' error' def = inputString cons' (fmap show def)
+ `transform` transformRead error'
+
+inputBool :: (Monad m, Functor m, HttpInput i)
+ => (FormId -> Bool -> v) -- ^ View constructor
+ -> Bool -- ^ Default input
+ -> Form m i e v Bool -- ^ Resulting form
+inputBool = input toView toResult
+ where
+ toView isInput inp def = if isInput then readBool inp else def
+ toResult inp _ = Ok $ readBool inp
+ readBool (Just x) = not (null $ getInputString x)
+ readBool Nothing = False
+
+inputChoice :: (Monad m, Functor m, HttpInput i, Monoid v, Eq a)
+ => (FormId -> String -> Bool -> a -> v) -- ^ Choice constructor
+ -> a -- ^ Default option
+ -> [a] -- ^ Choices
+ -> Form m i e v a -- ^ Resulting form
+inputChoice toView defaultInput choices = Form $ do
+ inputKey <- fromMaybe "" . fmap getInputString <$> getFormInput
+ id' <- getFormId
+ let -- Find the actual input, based on the key, or use the default input
+ inp = fromMaybe defaultInput $ lookup inputKey $ zip (ids id') choices
+ -- Apply the toView' function to all choices
+ view' = mconcat $ zipWith (toView' id' inp) (ids id') choices
+ return (View (const view'), Ok inp)
+ where
+ ids id' = map (((show id' ++ "-") ++) . show) [1 .. length choices]
+ toView' id' inp key x = toView id' key (inp == x) x
diff --git a/digestive-functors.cabal b/digestive-functors.cabal
index 4074df5..ae287a1 100644
--- a/digestive-functors.cabal
+++ b/digestive-functors.cabal
@@ -22,6 +22,7 @@ Library
Text.Digestive.Types,
Text.Digestive.Transform,
Text.Digestive.Html,
+ Text.Digestive.Http,
Text.Digestive.Blaze.Html5,
Text.Digestive.Result,
Text.Digestive.Cli,
diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs
index 3da3c4b..0ac2d02 100644
--- a/tests/TestSuite.hs
+++ b/tests/TestSuite.hs
@@ -7,15 +7,15 @@ module TestSuite
import Test.Framework (defaultMain, testGroup)
import qualified Text.Digestive.Validate.Tests (tests)
-import qualified Text.Digestive.Common.Tests (tests)
+import qualified Text.Digestive.Http.Tests (tests)
import qualified Text.Digestive.Types.Tests (tests)
main :: IO ()
main = defaultMain
[ testGroup "Text.Digestive.Validate.Tests"
Text.Digestive.Validate.Tests.tests
- , testGroup "Text.Digestive.Common.Tests"
- Text.Digestive.Common.Tests.tests
+ , testGroup "Text.Digestive.Http.Tests"
+ Text.Digestive.Http.Tests.tests
, testGroup "Text.Digestive.Types.Tests"
Text.Digestive.Types.Tests.tests
]
diff --git a/tests/Text/Digestive/Common/Tests.hs b/tests/Text/Digestive/Http/Tests.hs
similarity index 90%
rename from tests/Text/Digestive/Common/Tests.hs
rename to tests/Text/Digestive/Http/Tests.hs
index dc2da1b..1a8b030 100644
--- a/tests/Text/Digestive/Common/Tests.hs
+++ b/tests/Text/Digestive/Http/Tests.hs
@@ -1,4 +1,5 @@
-module Text.Digestive.Common.Tests
+{-# LANGUAGE TypeSynonymInstances #-}
+module Text.Digestive.Http.Tests
( tests
) where
@@ -10,8 +11,10 @@ import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (Assertion, (@?), (@=?))
import Text.Digestive.Tests.Util
+import Text.Digestive.Result
import Text.Digestive.Types
import Text.Digestive.Common
+import Text.Digestive.Http
tests :: [Test]
tests = [ testProperty "pass through" passThrough
@@ -20,6 +23,9 @@ tests = [ testProperty "pass through" passThrough
, testCase "test input bool" testInputBool
]
+instance HttpInput String where
+ getInputString = id
+
-- Build a test case: give a string as only input, run it through a form, the
-- result should stay the same
passThrough :: String -> Bool
@@ -51,6 +57,7 @@ labelId = unId $ do
[l1, l2, l3] <- viewForm form "form"
return $ l1 == l2 && l2 == l3 @? "ID's should be the same"
where
+ form :: Form Id String e [FormId] String
form = label return ++> inputString (\x _ -> [x]) Nothing <++ label return
-- Check that bool inputs work