digestive-functors (empty) → 0.0.1
raw patch · 12 files changed
+882/−0 lines, 12 filesdep +basedep +blaze-htmldep +containerssetup-changed
Dependencies added: base, blaze-html, containers, monads-fd
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- Text/Digestive.hs +13/−0
- Text/Digestive/Blaze/Html5.hs +138/−0
- Text/Digestive/Cli.hs +93/−0
- Text/Digestive/Common.hs +102/−0
- Text/Digestive/Html.hs +75/−0
- Text/Digestive/Result.hs +82/−0
- Text/Digestive/Transform.hs +73/−0
- Text/Digestive/Types.hs +182/−0
- Text/Digestive/Validate.hs +62/−0
- digestive-functors.cabal +30/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Jasper Van der Jeugt++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Jeremy Shaw nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/Digestive.hs view
@@ -0,0 +1,13 @@+-- | Module re-exporting all core definitions+--+module Text.Digestive+ ( module Text.Digestive.Result+ , module Text.Digestive.Types+ , module Text.Digestive.Transform+ , module Text.Digestive.Validate+ ) where++import Text.Digestive.Result+import Text.Digestive.Types+import Text.Digestive.Transform+import Text.Digestive.Validate
+ Text/Digestive/Blaze/Html5.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.Digestive.Blaze.Html5+ ( BlazeFormHtml+ , inputText+ , inputTextArea+ , inputTextRead+ , inputPassword+ , inputCheckBox+ , inputRadio+ , label+ , errors+ , childErrors+ , module Text.Digestive.Html+ ) where++import Control.Monad (forM_, unless, when)+import Data.Maybe (fromMaybe)+import Data.Monoid (mempty)++import Text.Blaze.Html5 (Html, (!))+import qualified Text.Blaze.Html5 as H+import qualified Text.Blaze.Html5.Attributes as A++import Text.Digestive.Types+import qualified Text.Digestive.Common as Common+import Text.Digestive.Html++-- | Form HTML generated by blaze+--+type BlazeFormHtml = FormHtml Html++-- | 'applyClasses' instantiated for blaze+--+applyClasses' :: [FormHtmlConfig -> [String]] -- ^ Labels to apply+ -> FormHtmlConfig -- ^ Label configuration+ -> Html -- ^ HTML element+ -> Html -- ^ Resulting element+applyClasses' = applyClasses $ \element value ->+ element ! A.class_ (H.stringValue value)++-- | Checks the input element when the argument is true+--+checked :: Bool -> Html -> Html+checked False x = x+checked True x = x ! A.checked "checked"++inputText :: (Monad m, Functor m)+ => Maybe String+ -> Form m String e BlazeFormHtml String+inputText = Common.inputString $ \id' inp -> FormHtml $ \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 -> FormHtml $ \cfg ->+ applyClasses' [htmlInputClasses] cfg $ rows r $ cols c $+ H.textarea ! A.name (H.stringValue $ show id')+ ! A.id (H.stringValue $ show id')+ $ H.string $ fromMaybe "" inp+ where+ rows Nothing = id+ rows (Just x) = (! A.rows (H.stringValue $ show x))+ cols Nothing = id+ cols (Just x) = (! A.cols (H.stringValue $ show x))++inputTextRead :: (Monad m, Functor m, Show a, Read a)+ => e+ -> Maybe a+ -> Form m String e BlazeFormHtml a+inputTextRead error' = flip Common.inputRead error' $ \id' inp ->+ FormHtml $ \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 ->+ FormHtml $ \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)+ => Bool+ -> Form m String e BlazeFormHtml Bool+inputCheckBox inp = flip Common.inputBool inp $ \id' inp' ->+ FormHtml $ \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)+ where+ toView group id' sel val = FormHtml $ \cfg -> do+ applyClasses' [htmlInputClasses] cfg $ checked sel $+ H.input ! A.type_ "radio"+ ! A.name (H.stringValue $ show group)+ ! A.value (H.stringValue id')+ ! A.id (H.stringValue id')+ H.label ! A.for (H.stringValue id')+ $ fromMaybe mempty $ lookup val choices+ when br H.br++label :: Monad m+ => String+ -> Form m i e BlazeFormHtml ()+label string = Common.label $ \id' -> FormHtml $ \cfg ->+ applyClasses' [htmlLabelClasses] cfg $+ H.label ! A.for (H.stringValue $ show id')+ $ H.string string++errorList :: [Html] -> BlazeFormHtml+errorList errors' = FormHtml $ \cfg -> unless (null errors') $+ applyClasses' [htmlErrorListClasses] cfg $+ H.ul $ forM_ errors' $ applyClasses' [htmlErrorClasses] cfg . H.li++errors :: Monad m+ => Form m i Html BlazeFormHtml ()+errors = Common.errors errorList++childErrors :: Monad m+ => Form m i Html BlazeFormHtml ()+childErrors = Common.childErrors errorList
+ Text/Digestive/Cli.hs view
@@ -0,0 +1,93 @@+-- | Proof-of-concept module: use digestive functors for a command line+-- interface prompt+--+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Text.Digestive.Cli+ ( Descriptions (..)+ , Prompt+ , prompt+ , runPrompt+ ) where++import Data.Map (Map)+import qualified Data.Map as M+import Data.Monoid (Monoid, mempty, mappend)+import Control.Applicative ((<$>))++import Text.Digestive.Result+import Text.Digestive.Types+import qualified Text.Digestive.Common as Common++newtype Descriptions = Descriptions+ { unDescriptions :: Map FormId [String]+ } deriving (Show)++instance Monoid Descriptions where+ mempty = Descriptions mempty+ mappend (Descriptions m1) (Descriptions m2) =+ Descriptions $ M.unionWith (++) m1 m2++type Prompt a = Form IO String String Descriptions a++-- | Remove the descriptions for the inputs already in the input map.+--+neededDescriptions :: InputMap -> Descriptions -> Descriptions+neededDescriptions (InputMap inputMap) =+ Descriptions . M.filterWithKey notInInput . unDescriptions+ where+ notInInput k _ = k `notElem` map fst inputMap++-- | Add errors to the descriptions+--+addErrors :: [(FormRange, String)] -> Descriptions -> Descriptions+addErrors errors (Descriptions descr) = Descriptions $ foldl add' descr errors+ where+ add' map' ((FormRange x _, e)) = M.insertWith (++) x [e] map'++newtype InputMap = InputMap+ { unInputMap :: [(FormId, String)]+ } deriving (Show, Monoid)++inputMapEnvironment :: Monad m => InputMap -> Environment m String+inputMapEnvironment map' = Environment $ return . flip lookup (unInputMap map')++promptOnce :: Descriptions -> IO (FormId, String)+promptOnce (Descriptions descr)+ | M.null descr = error "No descriptions!"+ | otherwise = do putStrLn ""+ mapM_ putStrLn description+ putStr "> "+ (,) key <$> getLine+ where+ (key, description) = M.findMin descr++-- | Remove all input for which errors are found+--+removeInvalidInput :: InputMap -> [(FormRange, String)] -> InputMap+removeInvalidInput = foldl removeInvalidInput'+ where+ removeInvalidInput' :: InputMap -> (FormRange, String) -> InputMap+ removeInvalidInput' (InputMap map') (range, _) =+ InputMap $ filter (not . flip isInRange range . fst) map'++prompt :: String -> Prompt String+prompt descr = Common.input (const $ const $ const [])+ toResult+ (\x _ -> Descriptions $ M.singleton x [descr])+ ""+ where+ toResult Nothing _ = Error []+ toResult (Just x) _ = Ok x++runPrompt :: Prompt a -> IO a+runPrompt form = prompt' mempty+ where+ prompt' inputMap = do+ (v, r) <- runForm form "form" $ inputMapEnvironment inputMap+ case r of+ Ok x -> return x+ Error e -> do let inputMap' = removeInvalidInput inputMap e+ descr = addErrors e+ $ neededDescriptions inputMap' (unView v [])+ input' <- promptOnce descr+ prompt' $ inputMap' `mappend` InputMap [input']
+ Text/Digestive/Common.hs view
@@ -0,0 +1,102 @@+-- | Functions to construct common forms+--+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++input :: (Monad m, Functor m)+ => (Bool -> Maybe String -> d -> s) -- ^ Get the viewed result+ -> (Maybe String -> FormRange -> Result e a) -- ^ Get the returned result+ -> (FormId -> s -> v) -- ^ View constructor+ -> d -- ^ Default value+ -> Form m String e v a -- ^ Resulting form+input toView toResult createView defaultInput = Form $ do+ isInput <- isFormInput+ inp <- getFormInput+ id' <- getFormId+ range <- getFormRange+ let view' = toView isInput inp defaultInput+ 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 ()+label f = Form $ do+ id' <- getFormId+ return (View (const $ f id'), Ok ())++errors :: Monad m+ => ([e] -> v)+ -> Form m i e v ()+errors f = Form $ do+ range <- getFormRange+ return (View (f . retainErrors range), Ok ())++childErrors :: Monad m+ => ([e] -> v)+ -> Form m i e v ()+childErrors f = Form $ do+ range <- getFormRange+ return (View (f . retainChildErrors range), Ok ())
+ Text/Digestive/Html.hs view
@@ -0,0 +1,75 @@+-- | General functions for forms that are rendered to some sort of HTML+module Text.Digestive.Html+ ( FormHtmlConfig (..)+ , FormHtml (..)+ , applyClasses+ , defaultHtmlConfig+ , emptyHtmlConfig+ , renderFormHtml+ , renderFormHtmlWith+ ) where++import Data.Monoid (Monoid (..))+import Data.List (intercalate)+import Control.Applicative ((<*>), pure)++-- | Settings for classes in generated HTML.+--+data FormHtmlConfig = FormHtmlConfig+ { htmlInputClasses :: [String] -- ^ Classes applied to input elements+ , htmlLabelClasses :: [String] -- ^ Classes applied to labels+ , htmlErrorClasses :: [String] -- ^ Classes applied to errors+ , htmlErrorListClasses :: [String] -- ^ Classes for error lists+ } deriving (Show)++-- | HTML describing a form+--+newtype FormHtml a = FormHtml+ { unFormHtml :: FormHtmlConfig -> a+ }++instance Monoid a => Monoid (FormHtml a) where+ mempty = FormHtml $ const mempty+ mappend (FormHtml x) (FormHtml y) = FormHtml $ \c -> mappend (x c) (y c)++-- | Apply all classes to an HTML element. If no classes are found, nothing+-- happens.+--+applyClasses :: (a -> String -> a) -- ^ Apply the class attribute+ -> [FormHtmlConfig -> [String]] -- ^ Labels to apply+ -> FormHtmlConfig -- ^ Label configuration+ -> a -- ^ HTML element+ -> a -- ^ Resulting element+applyClasses applyAttribute fs cfg element = case concat (fs <*> pure cfg) of+ [] -> element -- No labels to apply+ classes -> applyAttribute element $ intercalate " " classes++-- | Default configuration+--+defaultHtmlConfig :: FormHtmlConfig+defaultHtmlConfig = FormHtmlConfig+ { htmlInputClasses = ["digestive-input"]+ , htmlLabelClasses = ["digestive-label"]+ , htmlErrorClasses = ["digestive-error"]+ , htmlErrorListClasses = ["digestive-error-list"]+ }++-- | Empty configuration (no classes are set)+--+emptyHtmlConfig :: FormHtmlConfig+emptyHtmlConfig = FormHtmlConfig+ { htmlInputClasses = []+ , htmlLabelClasses = []+ , htmlErrorClasses = []+ , htmlErrorListClasses = []+ }++-- | Render FormHtml using the default configuration+--+renderFormHtml :: FormHtml a -> a+renderFormHtml = renderFormHtmlWith defaultHtmlConfig++-- | Render FormHtml using a custom configuration+--+renderFormHtmlWith :: FormHtmlConfig -> FormHtml a -> a+renderFormHtmlWith cfg = ($ cfg) . unFormHtml
+ Text/Digestive/Result.hs view
@@ -0,0 +1,82 @@+-- | Module for the core result type, and related functions+--+module Text.Digestive.Result+ ( Result (..)+ , FormId (..)+ , FormRange (..)+ , incrementFormId+ , isInRange+ , isSubRange+ , retainErrors+ , retainChildErrors+ ) where++import Control.Applicative (Applicative (..))++-- | Type for failing computations+--+data Result e ok = Error [(FormRange, e)]+ | Ok ok+ deriving (Show)++instance Functor (Result e) where+ fmap _ (Error x) = Error x+ fmap f (Ok x) = Ok (f x)++instance Monad (Result e) where+ return = Ok+ Error x >>= _ = Error x+ Ok x >>= f = f x++instance Applicative (Result e) where+ pure = Ok+ Error x <*> Error y = Error $ x ++ y+ Error x <*> Ok _ = Error x+ Ok _ <*> Error y = Error y+ Ok x <*> Ok y = Ok $ x y++-- | An ID used to identify forms+--+data FormId = FormId+ { formPrefix :: String+ , formId :: Integer+ } deriving (Eq, Ord)++instance Show FormId where+ show (FormId p x) = p ++ "-f" ++ show x++-- | A range of ID's to specify a group of forms+--+data FormRange = FormRange FormId FormId+ deriving (Eq, Show)++-- | Increment a form ID+--+incrementFormId :: FormId -> FormId+incrementFormId (FormId p x) = FormId p $ x + 1++-- | Check if a 'FormId' is contained in a 'FormRange'+--+isInRange :: FormId -- ^ Id to check for+ -> FormRange -- ^ Range+ -> Bool -- ^ If the range contains the id+isInRange (FormId _ a) (FormRange b c) = a >= formId b && a < formId c++-- | Check if a 'FormRange' is contained in another 'FormRange'+--+isSubRange :: FormRange -- ^ Sub-range+ -> FormRange -- ^ Larger range+ -> Bool -- ^ If the sub-range is contained in the larger range+isSubRange (FormRange a b) (FormRange c d) = formId a >= formId c+ && formId b <= formId d++-- | Select the errors for a certain range+--+retainErrors :: FormRange -> [(FormRange, e)] -> [e]+retainErrors range = map snd . filter ((== range) . fst)++-- | Select the errors originating from this form or from any of the children of+-- this form+--+retainChildErrors :: FormRange -> [(FormRange, e)] -> [e]+retainChildErrors range = map snd . filter ((`isSubRange` range) . fst)
+ Text/Digestive/Transform.hs view
@@ -0,0 +1,73 @@+-- | Optionally failing transformers for forms+--+module Text.Digestive.Transform+ ( Transformer (..)+ , transform+ , transformEither+ , transformEitherM+ , transformRead+ ) where++import Prelude hiding ((.), id)++import Control.Monad.Trans (lift)+import Control.Monad ((<=<))+import Control.Category (Category, (.), id)+import Control.Arrow (Arrow, arr, first)++import Text.Digestive.Result+import Text.Digestive.Types++-- | A transformer that transforms a value of type a to a value of type b+--+newtype Transformer m e a b = Transformer+ { unTransformer :: a -> m (Either [e] b)+ }++instance Monad m => Category (Transformer m e) where+ id = Transformer $ return . Right+ f . g = Transformer $ either (return . Left) (unTransformer f)+ <=< unTransformer g++instance Monad m => Arrow (Transformer m e) where+ arr f = Transformer $ return . Right . f+ first t = Transformer $ \(x, y) -> unTransformer t x >>=+ return . either Left (Right . (flip (,) y))++-- | Apply a transformer to a form+--+transform :: Monad m => Form m i e v a -> Transformer m e a b -> Form m i e v b+transform form transformer = Form $ do+ (v1, r1) <- unForm form+ range <- getFormRange+ case r1 of+ -- We already have an error, cannot continue+ Error e -> return (v1, Error e)+ -- Apply transformer+ Ok x -> do+ r2 <- lift $ lift $ unTransformer transformer x+ return $ case r2 of+ -- Attach the range information to the errors+ Left e -> (v1, Error $ map ((,) range) e)+ -- All fine+ Right y -> (v1, Ok y)++-- | Build a transformer from a simple function that returns an 'Either' result.+--+transformEither :: Monad m => (a -> Either e b) -> Transformer m e a b+transformEither f = transformEitherM $ return . f++-- | A monadic version of 'transformEither'+--+transformEitherM :: Monad m => (a -> m (Either e b)) -> Transformer m e a b+transformEitherM f = Transformer $ + return . either (Left . return) (Right . id) <=< f++-- | Create a transformer for any value of type a that is an instance of 'Read'+--+transformRead :: (Monad m, Read a)+ => e -- ^ Error given if read fails+ -> Transformer m e String a -- ^ Resulting transformer+transformRead error' = transformEither $ \str -> case readsPrec 1 str of+ [(x, "")] -> Right x+ _ -> Left error'
+ Text/Digestive/Types.hs view
@@ -0,0 +1,182 @@+-- | Core types+--+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Text.Digestive.Types+ ( View (..)+ , Environment (..)+ , FormState+ , getFormId+ , getFormRange+ , getFormInput+ , isFormInput+ , Form (..)+ , view+ , (++>)+ , (<++)+ , mapView+ , runForm+ , eitherForm+ ) where++import Data.Monoid (Monoid (..))+import Control.Arrow (first)+import Control.Monad (liftM2, mplus)+import Control.Monad.Reader (ReaderT, ask, runReaderT)+import Control.Monad.State (StateT, get, put, evalStateT)+import Control.Monad.Trans (lift)+import Control.Applicative (Applicative (..))++import Text.Digestive.Result++-- | A view represents a visual representation of a form. It is composed of a+-- function which takes a list of all errors and then produces a new view+--+newtype View e v = View+ { unView :: [(FormRange, e)] -> v+ }++instance Monoid v => Monoid (View e v) where+ mempty = View $ const mempty+ mappend (View f) (View g) = View $ \err -> mappend (f err) (g err)++instance Functor (View e) where+ fmap f (View g) = View $ f . g++-- | The environment is where you get the actual input per form. The environment+-- itself is optional+--+data Environment m i = Environment (FormId -> m (Maybe i))+ | NoEnvironment++instance Monad m => Monoid (Environment m i) where+ mempty = NoEnvironment+ NoEnvironment `mappend` x = x+ x `mappend` NoEnvironment = x+ (Environment env1) `mappend` (Environment env2) = Environment $ \id' ->+ liftM2 mplus (env1 id') (env2 id')++-- | The form state is a state monad under which our applicatives are composed+--+type FormState m i a = ReaderT (Environment m i) (StateT FormRange m) a++-- | Utility function: returns the current 'FormId'. This will only make sense+-- if the form is not composed+--+getFormId :: Monad m => FormState m i FormId+getFormId = do+ FormRange x _ <- get+ return x++-- | Utility function: Get the current range+--+getFormRange :: Monad m => FormState m i FormRange+getFormRange = get++-- | Utility function: Get the current input+--+getFormInput :: Monad m => FormState m i (Maybe i)+getFormInput = do+ id' <- getFormId+ env <- ask+ case env of Environment f -> lift $ lift $ f id'+ NoEnvironment -> return Nothing++-- | Check if any form input is present+--+isFormInput :: Monad m => FormState m i Bool+isFormInput = ask >>= \env -> return $ case env of+ Environment _ -> True+ NoEnvironment -> False++-- | A form represents a number of composed fields+--+newtype Form m i e v a = Form {unForm :: FormState m i (View e v, Result e a)}++instance Monad m => Functor (Form m i e v) where+ fmap f form = Form $ do+ (view', result) <- unForm form+ return (view', fmap f result)++instance (Monad m, Monoid v) => Applicative (Form m i e v) where+ pure x = Form $ return (mempty, return x)+ f1 <*> f2 = Form $ do+ -- Assuming f1 already has a valid ID+ FormRange startF1 _ <- get+ (v1, r1) <- unForm f1+ FormRange _ endF1 <- get++ -- Set a new, empty range+ put $ FormRange endF1 $ incrementFormId endF1+ (v2, r2) <- unForm f2+ FormRange _ endF2 <- get++ put $ FormRange startF1 endF2+ return (v1 `mappend` v2, r1 <*> r2)++-- | Insert a view into the functor+--+view :: Monad m+ => v -- ^ View to insert+ -> Form m i e v () -- ^ Resulting form+view view' = Form $ return (View (const view'), Ok ())++-- | Append a unit form to the left. This is useful for adding labels or error+-- fields+--+(++>) :: (Monad m, Monoid v)+ => Form m i e v ()+ -> Form m i e v a+ -> Form m i e v a+f1 ++> f2 = Form $ do+ -- Evaluate the form that matters first, so we have a correct range set+ (v2, r) <- unForm f2+ (v1, _) <- unForm f1+ return (v1 `mappend` v2, r)++infixl 6 ++>++-- | Append a unit form to the right. See '++>'.+--+(<++) :: (Monad m, Monoid v)+ => Form m i e v a+ -> Form m i e v ()+ -> Form m i e v a+f1 <++ f2 = Form $ do+ -- Evaluate the form that matters first, so we have a correct range set+ (v1, r) <- unForm f1+ (v2, _) <- unForm f2+ return (v1 `mappend` v2, r)++infixr 5 <++++-- | Change the view of a form using a simple function+--+mapView :: (Monad m, Functor m)+ => (v -> w) -- ^ Manipulator+ -> Form m i e v a -- ^ Initial form+ -> Form m i e w a -- ^ Resulting form+mapView f = Form . fmap (first $ fmap f) . unForm++-- | Run a form+--+runForm :: Monad m+ => Form m i e v a -- ^ Form to run+ -> String -- ^ Identifier for the form+ -> Environment m i -- ^ Input environment+ -> m (View e v, Result e a) -- ^ Result+runForm form id' env = evalStateT (runReaderT (unForm form) env) $+ FormRange f0 $ incrementFormId f0+ where+ f0 = FormId id' 0++-- | Evaluate a form to it's view if it fails+--+eitherForm :: Monad m+ => Form m i e v a -- ^ Form to run+ -> String -- ^ Identifier for the form+ -> Environment m i -- ^ Input environment+ -> m (Either v a) -- ^ Result+eitherForm form id' env = do+ (view', result) <- runForm form id' env+ return $ case result of Error e -> Left $ unView view' e+ Ok x -> Right x
+ Text/Digestive/Validate.hs view
@@ -0,0 +1,62 @@+-- | Validators that can be attached to forms+--+module Text.Digestive.Validate+ ( Validator+ , validate+ , validateMany+ , check+ , checkM+ ) where++import Prelude hiding (id)++import Control.Monad (liftM2)+import Data.Monoid (Monoid (..))+import Control.Category (id)++import Text.Digestive.Types+import Text.Digestive.Transform++-- | A validator. Invariant: the validator should not modify the result value,+-- only check it.+--+newtype Validator m e a = Validator {unValidator :: Transformer m e a a}++instance Monad m => Monoid (Validator m e a) where+ mempty = Validator id+ v1 `mappend` v2 = Validator $ Transformer $ \inp ->+ liftM2 eitherPlus (unTransformer (unValidator v1) inp)+ (unTransformer (unValidator v2) inp)+ where+ eitherPlus (Left e) (Left i) = Left $ e ++ i+ eitherPlus (Left e) (Right _) = Left e+ eitherPlus (Right _) (Left e) = Left e+ eitherPlus (Right a) (Right _) = Right a++-- | Attach a validator to a form.+--+validate :: Monad m => Form m i e v a -> Validator m e a -> Form m i e v a+validate form = transform form . unValidator++-- | Attach multiple validators to a form.+--+validateMany :: Monad m => Form m i e v a -> [Validator m e a] -> Form m i e v a+validateMany form = validate form . mconcat++-- | Easy way to create a pure validator+--+check :: Monad m+ => e -- ^ Error message+ -> (a -> Bool) -- ^ Actual validation+ -> Validator m e a -- ^ Resulting validator+check error' = checkM error' . (return .)++-- | Easy way to create a monadic validator+--+checkM :: Monad m+ => e -- ^ Error message+ -> (a -> m Bool) -- ^ Actual validation+ -> Validator m e a -- ^ Resulting validator+checkM error' f = Validator $ Transformer $ \x -> do+ valid <- f x+ return $ if valid then Right x else Left [error']
+ digestive-functors.cabal view
@@ -0,0 +1,30 @@+Name: digestive-functors+Version: 0.0.1+Synopsis: A general way to consume input using applicative functors+Description: Digestive functors is a library to generate and process+ HTML forms. You can find an introduction here:++ <http://github.com/jaspervdj/digestive-functors/blob/master/README.lhs>++Homepage: http://github.com/jaspervdj/digestive-functors+License: BSD3+License-file: LICENSE+Author: Jasper Van der Jeugt+Maintainer: jaspervdj@gmail.com+Category: Web+Build-type: Simple+Cabal-version: >=1.2+++Library+ Exposed-modules: Text.Digestive.Validate,+ Text.Digestive.Common,+ Text.Digestive.Types,+ Text.Digestive.Transform,+ Text.Digestive.Html,+ Text.Digestive.Blaze.Html5,+ Text.Digestive.Result,+ Text.Digestive.Cli,+ Text.Digestive+ Build-depends: base >= 4 && < 5,+ blaze-html, monads-fd, containers