digestive-functors 0.0.1 → 0.0.2.0

raw patch · 20 files changed

+823/−842 lines, 20 filesdep +bytestringdep +textdep −blaze-htmldep ~containersdep ~monads-fdPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bytestring, text

Dependencies removed: blaze-html

Dependency ranges changed: containers, monads-fd

API changes (from Hackage documentation)

Files

• LICENSE +18/−17
• Text/Digestive.hs +0/−13
• Text/Digestive/Blaze/Html5.hs +0/−138
• Text/Digestive/Cli.hs +0/−93
• Text/Digestive/Common.hs +0/−102
• Text/Digestive/Html.hs +0/−75
• Text/Digestive/Result.hs +0/−82
• Text/Digestive/Transform.hs +0/−73
• Text/Digestive/Types.hs +0/−182
• Text/Digestive/Validate.hs +0/−62
• digestive-functors.cabal +9/−5
• src/Text/Digestive.hs +13/−0
• src/Text/Digestive/Cli.hs +116/−0
• src/Text/Digestive/Common.hs +46/−0
• src/Text/Digestive/Forms.hs +96/−0
• src/Text/Digestive/Forms/Html.hs +112/−0
• src/Text/Digestive/Result.hs +82/−0
• src/Text/Digestive/Transform.hs +73/−0
• src/Text/Digestive/Types.hs +196/−0
• src/Text/Digestive/Validate.hs +62/−0

@@ -1,22 +1,23 @@-Copyright (c)2010, Jasper Van der Jeugt-+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.-+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 Jasper Van der Jeugt 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

@@ -1,13 +0,0 @@--- | 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

@@ -1,138 +0,0 @@-{-# 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

@@ -1,93 +0,0 @@--- | 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']

@@ -1,102 +0,0 @@--- | 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 ())

@@ -1,75 +0,0 @@--- | 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

@@ -1,82 +0,0 @@--- | 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)

@@ -1,73 +0,0 @@--- | 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'

@@ -1,182 +0,0 @@--- | 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

@@ -1,62 +0,0 @@--- | 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']

@@ -1,10 +1,10 @@ Name:                digestive-functors-Version:             0.0.1+Version:             0.0.2.0 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>+    <http://github.com/jaspervdj/digestive-functors/blob/master/digestive-functors/README.lhs>  Homepage:            http://github.com/jaspervdj/digestive-functors License:             BSD3@@ -17,14 +17,18 @@   Library+  Hs-source-dirs:      src   Exposed-modules:     Text.Digestive.Validate,                        Text.Digestive.Common,                        Text.Digestive.Types,                        Text.Digestive.Transform,-                       Text.Digestive.Html,-                       Text.Digestive.Blaze.Html5,+                       Text.Digestive.Forms,+                       Text.Digestive.Forms.Html,                        Text.Digestive.Result,                        Text.Digestive.Cli,                        Text.Digestive   Build-depends:       base >= 4 && < 5,-                       blaze-html, monads-fd, containers+                       monads-fd >= 0.1,+                       containers >= 0.3,+                       bytestring >= 0.9,+                       text >= 0.10

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

@@ -0,0 +1,116 @@+-- | Proof-of-concept module: use digestive functors for a command line+-- interface prompt+--+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Text.Digestive.Cli+    ( Descriptions (..)+    , Prompt+    , prompt+    , promptRead+    , 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 Text.Digestive.Transform+import qualified Text.Digestive.Common as Common++-- | A list of descriptions for a certain input prompt+--+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 for a prompt+--+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)++-- | Create an environment from an input map+--+inputMapEnvironment :: Monad m => InputMap -> Environment m String+inputMapEnvironment map' = Environment $ return . flip lookup (unInputMap map')++-- | Prompt once for a needed field. Return (key, value)+--+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'++-- | Generate a prompt field from a description+--+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++-- | Generate a prompt field for a value which can be read+--+promptRead :: Read a+           => String    -- ^ Error when the value can't be read+           -> String    -- ^ Description+           -> Prompt a  -- ^ Resulting prompt+promptRead error' descr = prompt descr `transform` transformRead error'++-- | Run a prompt. This will repeatedly prompt for input until we have a valid+-- result.+--+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']

@@ -0,0 +1,46 @@+-- | Functions to construct common forms+--+module Text.Digestive.Common+    ( input+    , label+    , errors+    , childErrors+    ) where++import Text.Digestive.Types+import Text.Digestive.Result++input :: (Monad m, Functor m)+      => (Bool -> Maybe i -> d -> s)  -- ^ Get the viewed result+      -> (Maybe i -> Result e a)      -- ^ Get the returned result+      -> (FormId -> s -> v)           -- ^ View constructor+      -> d                            -- ^ Default value+      -> Form m i e v a               -- ^ Resulting form+input toView toResult createView defaultInput = Form $ do+    isInput <- isFormInput+    inp <- getFormInput+    id' <- getFormId+    let view' = toView isInput inp defaultInput+        result' = toResult inp+    return (View (const $ createView id' view'), result')++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 ())

@@ -0,0 +1,96 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+module Text.Digestive.Forms+    ( FormInput (..)+    , inputString+    , inputRead+    , inputBool+    , inputChoice+    , inputFile+    ) where++import Control.Applicative ((<$>))+import Control.Monad (mplus)+import Data.Monoid (Monoid, mconcat)+import Data.Maybe (fromMaybe)++import Data.Text (Text)+import qualified Data.Text as T (pack)++import Text.Digestive.Common+import Text.Digestive.Types+import Text.Digestive.Result+import Text.Digestive.Transform++-- | Class which all backends should implement. @a@ is here the type that is+-- used to represent a value uploaded by the client in the request+--+class FormInput i f | i -> f where+    -- | Parse the input into a string. This is used for simple text fields+    -- among other things+    --+    getInputString :: i -> Maybe String++    -- | Parse the input value into 'Text'. The default implementation uses+    -- 'T.pack . getInputString', a more efficient version may be implemented.+    --+    getInputText :: i -> Maybe Text+    getInputText = fmap T.pack . getInputString++    -- | Get a file descriptor for an uploaded file+    --+    getInputFile :: i -> Maybe f++inputString :: (Monad m, Functor m, FormInput i f)+            => (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 = (getInputString =<< inp) `mplus` defaultInput+    toResult = Ok . fromMaybe "" . (getInputString =<<)++inputRead :: (Monad m, Functor m, FormInput i f, 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, FormInput i f)+          => (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 (getInputString =<< inp)+                                        else def+    toResult inp = Ok $ readBool (getInputString =<< inp)+    readBool (Just x) = not $ null x+    readBool Nothing  = False++inputChoice :: (Monad m, Functor m, FormInput i f, 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 "" . (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++inputFile :: (Monad m, Functor m, FormInput i f)+          => (FormId -> v)           -- ^ View constructor+          -> Form m i e v (Maybe f)  -- ^ Resulting form+inputFile viewCons = input toView toResult viewCons' ()+  where+    toView _ _ _ = ()+    toResult inp = Ok $ getInputFile =<< inp+    viewCons' id' () = viewCons id'

@@ -0,0 +1,112 @@+-- | General functions for forms that are rendered to some sort of HTML+--+module Text.Digestive.Forms.Html+    ( FormHtmlConfig (..)+    , FormEncType (..)+    , FormHtml (..)+    , createFormHtml+    , createFormHtmlWith+    , applyClasses+    , defaultHtmlConfig+    , emptyHtmlConfig+    , renderFormHtml+    , renderFormHtmlWith+    ) where++import Data.Monoid (Monoid (..))+import Data.List (intercalate)+import Control.Applicative ((<*>), pure)+import Control.Arrow ((&&&))++-- | Settings for classes in generated HTML.+--+data FormHtmlConfig = FormHtmlConfig+    { htmlInputClasses     :: [String]  -- ^ Classes applied to input elements+    , htmlSubmitClasses    :: [String]  -- ^ Classes applied to submit buttons+    , htmlLabelClasses     :: [String]  -- ^ Classes applied to labels+    , htmlErrorClasses     :: [String]  -- ^ Classes applied to errors+    , htmlErrorListClasses :: [String]  -- ^ Classes for error lists+    } deriving (Show)++-- | Encoding type for the form+--+data FormEncType = UrlEncoded+                 | MultiPart+                 deriving (Eq)++instance Show FormEncType where+    show UrlEncoded = "application/x-www-form-urlencoded"+    show MultiPart  = "multipart/form-data"++-- Monoid instance for encoding types: prefer UrlEncoded, but fallback to+-- MultiPart when needed+instance Monoid FormEncType where+    mempty = UrlEncoded+    mappend UrlEncoded x = x+    mappend MultiPart _ = MultiPart++-- | HTML describing a form+--+data FormHtml a = FormHtml+    { formEncType :: FormEncType+    , formHtml    :: FormHtmlConfig -> a+    }++instance Monoid a => Monoid (FormHtml a) where+    mempty = FormHtml mempty $ const mempty+    mappend (FormHtml x f) (FormHtml y g) =+        FormHtml (x `mappend` y) $ f `mappend` g++-- | Create form HTML with the default encoding type+--+createFormHtml :: (FormHtmlConfig -> a) -> FormHtml a+createFormHtml = FormHtml mempty++-- | Create form HTML with a custom encoding type+--+createFormHtmlWith :: FormEncType -> (FormHtmlConfig -> a) -> FormHtml a+createFormHtmlWith = FormHtml++-- | 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"]+    , htmlSubmitClasses    = ["digestive-submit"]+    , htmlLabelClasses     = ["digestive-label"]+    , htmlErrorClasses     = ["digestive-error"]+    , htmlErrorListClasses = ["digestive-error-list"]+    }++-- | Empty configuration (no classes are set)+--+emptyHtmlConfig :: FormHtmlConfig+emptyHtmlConfig = FormHtmlConfig+    { htmlInputClasses     = []+    , htmlSubmitClasses    = []+    , htmlLabelClasses     = []+    , htmlErrorClasses     = []+    , htmlErrorListClasses = []+    }++-- | Render FormHtml using the default configuration+--+renderFormHtml :: FormHtml a -> (a, FormEncType)+renderFormHtml = renderFormHtmlWith defaultHtmlConfig++-- | Render FormHtml using a custom configuration+--+renderFormHtmlWith :: FormHtmlConfig -> FormHtml a -> (a, FormEncType)+renderFormHtmlWith cfg = ($ cfg) . formHtml &&& formEncType

@@ -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, Eq)++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)

@@ -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'

@@ -0,0 +1,196 @@+-- | Core types+--+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Text.Digestive.Types+    ( View (..)+    , Environment (..)+    , fromList+    , FormState+    , getFormId+    , getFormRange+    , getFormInput+    , isFormInput+    , Form (..)+    , view+    , (++>)+    , (<++)+    , mapView+    , runForm+    , eitherForm+    , viewForm+    ) 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+    } deriving (Monoid)++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')++-- | Create an environment from a lookup table+--+fromList :: Monad m => [(FormId, i)] -> Environment m i+fromList list = Environment $ return . flip lookup list++-- | 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++-- | Just evaluate the form to a view. This usually maps to a GET request in the+-- browser.+--+viewForm :: Monad m+         => Form m i e v a  -- ^ Form to run+         -> String          -- ^ Identifier for the form+         -> m v             -- ^ Result+viewForm form id' = do+    (view', _) <- runForm form id' NoEnvironment+    return $ unView 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']