Add another abstraction layer for HTTP input

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

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 ()

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

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,

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
     ]

tests/Text/Digestive/Common/Tests.hs → 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