digestive-functors 0.2.1.0 → 0.3.0.0

raw patch · 17 files changed

+669/−1090 lines, 17 filesdep +HUnitdep +test-frameworkdep +test-framework-hunitdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, test-framework, test-framework-hunit

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• digestive-functors.cabal +64/−17
• src/Text/Digestive.hs +8/−8
• src/Text/Digestive/Cli.hs +0/−196
• src/Text/Digestive/Common.hs +0/−46
• src/Text/Digestive/Field.hs +59/−0
• src/Text/Digestive/Form.hs +92/−0
• src/Text/Digestive/Form/Encoding.hs +42/−0
• src/Text/Digestive/Form/Internal.hs +177/−0
• src/Text/Digestive/Forms.hs +0/−208
• src/Text/Digestive/Forms/Html.hs +0/−133
• src/Text/Digestive/Result.hs +0/−113
• src/Text/Digestive/Transform.hs +0/−91
• src/Text/Digestive/Types.hs +54/−216
• src/Text/Digestive/Util.hs +9/−0
• src/Text/Digestive/Validate.hs +0/−62
• src/Text/Digestive/View.hs +148/−0
• tests/TestSuite.hs +16/−0

@@ -1,39 +1,86 @@ Name:     digestive-functors-Version:  0.2.1.0-Synopsis: A general way to consume input using applicative functors+Version:  0.3.0.0+Synopsis: A practical formlet library -Description:         Digestive functors is a library to generate and process-    HTML forms.  You can find an introduction here:+Description:+    Digestive functors is a library inspired by formlets: -    <http://github.com/jaspervdj/digestive-functors/blob/master/digestive-functors/README.lhs>+    . +    <http://groups.inf.ed.ac.uk/links/formlets/>++    .++    It is intended to be an improvement of the Haskell formlets library, with as+    main advantages:++    .++    * better error handling, so a web page can display input errors right next+      to the corresponding fields;++    .++    * the ability to easily add @\<label\>@ elements;++    .++    * separation of the validation model and the HTML output.++    .++    Tutorial:+    <http://github.com/jaspervdj/digestive-functors/blob/master/examples/tutorial.lhs>+ Homepage:      http://github.com/jaspervdj/digestive-functors License:       BSD3 License-file:  LICENSE-Author:        Jasper Van der Jeugt-Maintainer:    jaspervdj@gmail.com+Author:        Jasper Van der Jeugt <m@jaspervdj.be>+Maintainer:    Jasper Van der Jeugt <m@jaspervdj.be> Category:      Web Build-type:    Simple-Cabal-version: >= 1.6+Cabal-version: >= 1.8  Library   Hs-source-dirs: src-  Ghc-options:    -Wall+  Ghc-options:    -Wall -fwarn-tabs    Exposed-modules:     -    Text.Digestive.Validate,-    Text.Digestive.Common,+    Text.Digestive,+    Text.Digestive.Form,+    Text.Digestive.Form.Encoding,     Text.Digestive.Types,-    Text.Digestive.Transform,-    Text.Digestive.Forms,-    Text.Digestive.Forms.Html,-    Text.Digestive.Result,-    Text.Digestive.Cli,-    Text.Digestive+    Text.Digestive.View,+    Text.Digestive.Util +  Other-modules:+    Text.Digestive.Field,+    Text.Digestive.Form.Internal+   Build-depends:     base       >= 4       && < 5,     bytestring >= 0.9,     containers >= 0.3,     mtl        >= 1.1.0.0 && < 3,     text       >= 0.10++Test-suite digestive-functors-tests+  Type:           exitcode-stdio-1.0+  Hs-source-dirs: src tests+  Main-is:        TestSuite.hs+  Ghc-options:    -Wall++  Build-depends:+    HUnit                >= 1.2 && < 1.3,+    test-framework       >= 0.4 && < 0.7,+    test-framework-hunit >= 0.2 && < 0.3,+    -- Copied from regular dependencies:+    base       >= 4       && < 5,+    bytestring >= 0.9,+    containers >= 0.3,+    mtl        >= 1.1.0.0 && < 3,+    text       >= 0.10++Source-repository head+  Type:     git+  Location: https://github.com/jaspervdj/digestive-functors

@@ -1,13 +1,13 @@--- | Module re-exporting all core definitions---+-- | Tutorial:+-- <http://github.com/jaspervdj/digestive-functors/blob/master/examples/tutorial.lhs> module Text.Digestive-    ( module Text.Digestive.Result+    ( module Text.Digestive.Form+    , module Text.Digestive.Form.Encoding     , module Text.Digestive.Types-    , module Text.Digestive.Transform-    , module Text.Digestive.Validate+    , module Text.Digestive.View     ) where -import Text.Digestive.Result+import Text.Digestive.Form+import Text.Digestive.Form.Encoding import Text.Digestive.Types-import Text.Digestive.Transform-import Text.Digestive.Validate+import Text.Digestive.View

@@ -1,196 +0,0 @@--- | Proof-of-concept module: use digestive functors for a command line--- interface prompt----{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Text.Digestive.Cli-    ( Prompt-    , prompt-    , promptList-    , promptRead-    , runPrompt-    ) where--import Control.Applicative ((<$>))-import Data.Monoid (Monoid, mappend, mempty)--import Text.Digestive.Result-import Text.Digestive.Types-import Text.Digestive.Transform-import Text.Digestive.Forms (inputList)---- A representation of an element in the structure used to gather inputs--- from the user.----data FieldItem-  -- A tangible item that the user is prompted for.-  = FieldItemSingle     FormId String [String]-  -- A delimter marking the start of a series of prompts to be entered-  -- multiple times.-  | FieldItemMultiStart FormId String [String]-  -- A delimiter marking the end of a multiple input prompt.-  | FieldItemMultiEnd-    deriving (Show)---- The structure of a prompt, built up as a View.----newtype PromptView = PromptView-    { unPromptView :: [FieldItem]-    } deriving (Show, Monoid)---- | Type for a prompt----type Prompt a = Form IO String String PromptView a---- An association list of FormIds and their inputs gathered by prompting the--- user.----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')---- | Generate a prompt field for a String----prompt :: String        -- ^ Description-       -> Prompt String -- ^ Resulting prompt-prompt descr = Form $ do-    id' <- getFormId-    inp <- getFormInput-    range <- getFormRange-    let v :: [(FormRange, String)] -> PromptView-        v errs = PromptView [FieldItemSingle id' descr matching]-          where-            -- Only errors which apply specifically to this item-            matching = retainErrors range errs-        result = case inp of-            Just x  -> Ok x-            Nothing -> Error [(range, "No input")]-    return (View v, return result)---- | Convert a prompt for a single item into a prompt for multiple items----promptList :: String     -- ^ Description of resulting multi-prompt-           -> Prompt a   -- ^ Prompt to convert-           -> Prompt [a] -- ^ Resulting multiple input prompt-promptList descr prmpt = Form $ do-    id'     <- getFormId-    (v, rs) <- unForm $ inputList numPrompt (const prmpt) Nothing-    range   <- getFormRange-    -- The monoid for the view will look like this: [vstart, v, vend]-    -- 'vstart' and 'vend' delimit the beginning and end of the inputs that-    -- are converted into repeatable inputs. When we are prompting the user to-    -- fill out the form, we use these delimiters to control the behavior of-    -- the prompts. Anything between them will be treated as repeatable. The-    -- 'vstart' item (FieldItemMultiStart) also contains the FormId of the-    -- field used to count the number of entries, as well as an additional-    -- description of of the multiple input itself (for example, 'Users', when-    -- the contained items are used to enter in a single User.)-    let vstart errs = PromptView [item]-          where-            item = FieldItemMultiStart id' descr $ retainErrors range errs-        vend _ = PromptView [FieldItemMultiEnd]-    return (View vstart `mappend` v `mappend` View vend, rs)-  where-    numPrompt _ = Form $ do-        inp <- getFormInput-        return (mempty, return (readN inp))-    readN (Just x) = Ok (read x)-    readN Nothing = Error []---- | 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'---- Get a single line of text from the user----cliInput :: IO String-cliInput = putStr "> " >> getLine---- Get the input for a list of prompt items that have been defined.------ Notably, this supports nested 'mass input' forms (inputList/promptList)--- which are delimited by FieldItemMultiStart and FieldItemMultiEnd.--- FieldItemMultiSingle represents a tangible item to prompt for. If a--- FieldItemMultiStart is reached, we need to prompt for all of the items--- until the next FieldItemMultiEnd an arbitrary number of times.----inputForItems :: [FieldItem]-              -- ^ Items to get input for-              -> [(FormId, String)]-              -- ^ Accumulated association list of inputs we've prompted for-              -> (FormId -> FormId)-              -- ^ A function to transform the FormId of this item. Used to-              -- change the index of the item when prompting multiple times.-              -> IO ([FieldItem], [(FormId, String)])-              -- ^ A pair of the remaining items (empty if we are not-              -- returning from a multiple input item) and accumulated inputs, -inputForItems [] accum _fid = return ([], accum)--inputForItems (FieldItemMultiEnd : rest) accum _fid = return (rest, accum)---- The simple case for a single item.-inputForItems (FieldItemSingle id' descr _errs : rest) accum fid = do-    putStrLn descr-    val <- cliInput-    inputForItems rest ((fid id', val) : accum) fid---- The case for a multiple input prompt.-inputForItems (FieldItemMultiStart id' descr _errs : rest) accum fid = do-    let id'' = fid id'-    putStrLn $ "How many '" ++ descr ++ "' do you want to input?"-    -- Leave this as a string, since we must put it into a hidden form field-    -- for inputList, which must read it again. We only prompt for it here-    -- instead of as a discrete form item because we want to know, right now,-    -- how many the user wants to input.-    nStr <- cliInput-    -- Prompt for all of the delimited items, and put them at index i for this-    -- multi-input item.-    -- TODO use foldM-    let f i = do putStrLn $ descr ++ " #" ++ show (i + 1) ++ ":"-                 inputForItems rest [] (modifyId id'' i)-    delimited <- mapM f [0..(read nStr - 1)]-    let rest' = fst $ last delimited-        countfield = (id'', nStr)-    inputForItems rest' ([countfield] ++ accum ++ concatMap snd delimited) fid---- Construct a function to transform the 'children' (delimited items) of a--- mass input item to the correct index.----modifyId :: FormId -> Integer -> FormId -> FormId-modifyId parent i = mapId (\x -> head x : i : formIdList parent)---- | Run a Prompt, sequentially prompting the user for each item.----runPrompt :: Prompt a-          -- ^ The Prompt to run-          -> IO (Either [String] a)-          -- ^ A list of error strings, or the result.-runPrompt prmpt = do-    prmptv <- viewForm prmpt "form"-    inpmap <- InputMap . snd <$> inputForItems (unPromptView prmptv) [] id-    eith   <- eitherForm prmpt "form" (inputMapEnvironment inpmap)-    return $ case eith of-        Left v  -> Left (fieldItemErrors `concatMap` unPromptView v)-        Right x -> Right x---- Read the errors from a FieldItem, if any.----fieldItemErrors :: FieldItem -> [String]-fieldItemErrors (FieldItemSingle id' descr errs) =-    descriptiveErrors id' descr errs-fieldItemErrors (FieldItemMultiStart id' descr errs) = -- TODO bad-    descriptiveErrors id' descr errs-fieldItemErrors FieldItemMultiEnd = []--descriptiveErrors :: FormId -> String -> [String] -> [String]-descriptiveErrors id' descr errs = map str errs-  where-    str err = "(" ++ show id' ++ ") " ++ descr ++ ": " ++ err

@@ -1,46 +0,0 @@--- | 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'), return result')--label :: Monad m-      => (FormId -> v)-      -> Form m i e v ()-label f = Form $ do-    id' <- getFormId-    return (View (const $ f id'), return (Ok ()))--errors :: Monad m-       => ([e] -> v)-       -> Form m i e v ()-errors f = Form $ do-    range <- getFormRange-    return (View (f . retainErrors range), return (Ok ()))--childErrors :: Monad m-            => ([e] -> v)-            -> Form m i e v ()-childErrors f = Form $ do-    range <- getFormRange-    return (View (f . retainChildErrors range), return (Ok ()))

@@ -0,0 +1,59 @@+{-# LANGUAGE ExistentialQuantification, GADTs, OverloadedStrings #-}+module Text.Digestive.Field+    ( Field (..)+    , SomeField (..)+    , evalField+    , fieldMapView+    ) where++import Control.Arrow (second)+import Data.Maybe (fromMaybe, listToMaybe)++import Data.Text (Text)+import qualified Data.Text as T++import Text.Digestive.Types+import Text.Digestive.Util++-- | A single input field. This usually maps to a single HTML @<input>@ element.+data Field v a where+    Singleton :: a -> Field v a+    Text      :: Text -> Field v Text+    Choice    :: Eq a => [(a, v)] -> Int -> Field v a+    Bool      :: Bool -> Field v Bool+    File      :: Field v (Maybe FilePath)++instance Show (Field v a) where+    show (Singleton _) = "Singleton _"+    show (Text t)      = "Text " ++ show t+    show (Choice _ _)  = "Choice _ _"+    show (Bool b)      = "Bool " ++ show b+    show (File)        = "File"++data SomeField v = forall a. SomeField (Field v a)++evalField :: Method       -- ^ Get/Post+          -> [FormInput]  -- ^ Given input+          -> Field v a    -- ^ Field+          -> a            -- ^ Result+evalField _    _                 (Singleton x) = x+evalField _    (TextInput x : _) (Text _)      = x+evalField _    _                 (Text x)      = x+evalField _    (TextInput x : _) (Choice ls y) = fromMaybe (fst $ ls !! y) $ do+    -- Expects input in the form of @foo.bar.2@+    t <- listToMaybe $ reverse $ toPath x+    i <- readMaybe $ T.unpack t+    return $ fst $ ls !! i+evalField _    _                 (Choice ls x) = fst $ ls !! x+evalField Get  _                 (Bool x)      = x+evalField Post (TextInput x : _) (Bool _)      = x == "on"+evalField Post _                 (Bool _)      = False+evalField Post (FileInput x : _) File          = Just x+evalField _    _                 File          = Nothing++fieldMapView :: (v -> w) -> Field v a -> Field w a+fieldMapView _ (Singleton x)   = Singleton x+fieldMapView _ (Text x)        = Text x+fieldMapView f (Choice xs i)   = Choice (map (second f) xs) i+fieldMapView _ (Bool x)        = Bool x+fieldMapView _ File            = File

@@ -0,0 +1,92 @@+{-# LANGUAGE ExistentialQuantification, GADTs, OverloadedStrings, Rank2Types #-}+module Text.Digestive.Form+    ( Form+    , SomeForm (..)+    , (.:)++      -- * Forms+    , text+    , string+    , stringRead+    , choice+    , bool+    , file++      -- * Validation+    , check+    , checkM+    , validate+    , validateM+    ) where++import Data.List (findIndex)+import Data.Maybe (fromMaybe)++import Data.Text (Text)+import qualified Data.Text as T++import Text.Digestive.Field+import Text.Digestive.Form.Internal+import Text.Digestive.Types+import Text.Digestive.Util++text :: Maybe Text -> Form v m Text+text def = Pure Nothing $ Text $ fromMaybe "" def++string :: Monad m => Maybe String -> Form v m String+string = fmap T.unpack . text . fmap T.pack++stringRead :: (Monad m, Read a, Show a) => v -> Maybe a -> Form v m a+stringRead err = transform readTransform . string . fmap show+  where+    readTransform = return . maybe (Error err) return . readMaybe++choice :: Eq a => [(a, v)] -> Maybe a -> Form v m a+choice items def = Pure Nothing $ Choice items $ fromMaybe 0 $+    maybe Nothing (\d -> findIndex ((== d) . fst) items) def++bool :: Bool           -- ^ Default value+     -> Form v m Bool  -- ^ Resulting form+bool = Pure Nothing . Bool++file :: Form v m (Maybe FilePath)+file = Pure Nothing File++-- | Validate the results of a form with a simple predicate+--+-- Example:+--+-- > check "Can't be empty" (not . null) (string Nothing)+check :: Monad m+      => v            -- ^ Error message (if fail)+      -> (a -> Bool)  -- ^ Validating predicate+      -> Form v m a   -- ^ Form to validate+      -> Form v m a   -- ^ Resulting form+check err = checkM err . (return .)++-- | Version of 'check' which allows monadic validations+checkM :: Monad m => v -> (a -> m Bool) -> Form v m a -> Form v m a+checkM err predicate form = validateM f form+  where+    f x = do+        r <- predicate x+        return $ if r then return x else Error err++-- | This is an extension of 'check' that can be used to apply transformations+-- that optionally fail+--+-- Example: taking the first character of an input string+--+-- > head' :: String -> Result String Char+-- > head' []      = Error "Is empty"+-- > head' (x : _) = Success x+-- >+-- > char :: Monad m => Form m String Char+-- > char = validate head' (string Nothing)+--+validate :: Monad m => (a -> Result v b) -> Form v m a -> Form v m b+validate = validateM . (return .)++-- | Version of 'validate' which allows monadic validations+validateM :: Monad m => (a -> m (Result v b)) -> Form v m a -> Form v m b+validateM = transform

@@ -0,0 +1,42 @@+{-# LANGUAGE GADTs #-}+module Text.Digestive.Form.Encoding+    ( FormEncType (..)+    , formEncType+    ) where++import Data.Maybe (mapMaybe)+import Data.Monoid (Monoid (..), mconcat)++import Text.Digestive.Field+import Text.Digestive.Form.Internal++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++fieldEncType :: Field v a -> FormEncType+fieldEncType File = MultiPart+fieldEncType _    = UrlEncoded++formEncType :: Form v m a -> FormEncType+formEncType = mconcat . map fieldEncType' . fieldList+  where+    fieldEncType' (SomeField f) = fieldEncType f++fieldList :: Form v m a -> [SomeField v]+fieldList = mapMaybe toField' . fieldList' . SomeForm+  where+    fieldList' (SomeForm f) = SomeForm f : concatMap fieldList' (children f)+    toField' (SomeForm f)   = toField f

@@ -0,0 +1,177 @@+-- | This module mostly meant for internal usage, and might change between minor+-- releases.+{-# LANGUAGE ExistentialQuantification, GADTs, OverloadedStrings, Rank2Types #-}+module Text.Digestive.Form.Internal+    ( Form (..)+    , SomeForm (..)+    , transform+    , children+    , (.:)+    , lookupForm+    , toField+    , queryField+    , eval+    , formMapView+    ) where++import Control.Applicative (Applicative (..))+import Control.Monad ((>=>))+import Data.Maybe (maybeToList)+import Data.Monoid (Monoid)++import Data.Text (Text)+import qualified Data.Text as T++import Text.Digestive.Types+import Text.Digestive.Field++type Ref = Maybe Text++-- | Base type for a form.+--+-- The three type parameters are:+--+-- * @v@: the type for textual information, displayed to the user. For example,+--   error messages are of this type. @v@ stands for "view".+--+-- * @m@: the monad in which validators operate. The classical example is when+--   validating input requires access to a database, in which case this @m@+--   should be an instance of @MonadIO@.+--+-- * @a@: the type of the value returned by the form, used for its Applicative+--   instance.+--+data Form v m a where+    Pure :: Ref -> Field v a -> Form v m a+    App  :: Ref -> Form v m (b -> a) -> Form v m b -> Form v m a++    Map  :: (b -> m (Result v a)) -> Form v m b -> Form v m a++instance Monad m => Functor (Form v m) where+    fmap = transform . (return .) . (return .)++instance (Monad m, Monoid v) => Applicative (Form v m) where+    pure x  = Pure Nothing (Singleton x)+    x <*> y = App Nothing x y++instance Show (Form v m a) where+    show = unlines . showForm++data SomeForm v m = forall a. SomeForm (Form v m a)++instance Show (SomeForm v m) where+    show (SomeForm f) = show f++showForm :: Form v m a -> [String]+showForm form = case form of+    (Pure r x)  -> ["Pure (" ++ show r ++ ") (" ++ show x ++ ")"]+    (App r x y) -> concat+        [ ["App (" ++ show r ++ ")"]+        , map indent (showForm x)+        , map indent (showForm y)+        ]+    (Map _ x)   -> "Map _" : map indent (showForm x)+  where+    indent = ("  " ++)++transform :: Monad m => (a -> m (Result v b)) -> Form v m a -> Form v m b+transform f (Map g x) = flip Map x $ \y -> bindResult (g y) f+transform f x         = Map f x++children :: Form v m a -> [SomeForm v m]+children (Pure _ _)  = []+children (App _ x y) = [SomeForm x, SomeForm y]+children (Map _ x)   = children x++setRef :: Ref -> Form v m a -> Form v m a+setRef r (Pure _ x)  = Pure r x+setRef r (App _ x y) = App r x y+setRef r (Map f x)   = Map f (setRef r x)++-- | Operator to set a name for a subform.+(.:) :: Text -> Form v m a -> Form v m a+(.:) = setRef . Just+infixr 5 .:++getRef :: Form v m a -> Ref+getRef (Pure r _)  = r+getRef (App r _ _) = r+getRef (Map _ x)   = getRef x++lookupForm :: Path -> Form v m a -> [SomeForm v m]+lookupForm path = go path . SomeForm+  where+    go []       form            = [form]+    go (r : rs) (SomeForm form) = case getRef form of+        Just r'+            -- Note how we use `setRef Nothing` to strip the ref away. This is+            -- really important.+            | r == r' && null rs -> [SomeForm $ setRef Nothing form]+            | r == r'            -> children form >>= go rs+            | otherwise          -> []+        Nothing                  -> children form >>= go (r : rs)++toField :: Form v m a -> Maybe (SomeField v)+toField (Pure _ x) = Just (SomeField x)+toField (Map _ x)  = toField x+toField _          = Nothing++queryField :: Path+           -> Form v m a+           -> (forall b. Field v b -> c)+           -> c+queryField path form f = case lookupForm path form of+    []                   -> error $ ref ++ " does not exist"+    (SomeForm form' : _) -> case toField form' of+        Just (SomeField field) -> f field+        _                      -> error $ ref ++ " is not a field"+  where+    ref = T.unpack $ fromPath path++ann :: Path -> Result v a -> Result [(Path, v)] a+ann _    (Success x) = Success x+ann path (Error x)   = Error [(path, x)]++eval :: Monad m => Method -> Env m -> Form v m a+     -> m (Result [(Path, v)] a, [(Path, FormInput)])+eval = eval' []++eval' :: Monad m => Path -> Method -> Env m -> Form v m a+      -> m (Result [(Path, v)] a, [(Path, FormInput)])++eval' context method env form = case form of++    Pure Nothing _ ->+        error "No ref specified for field"++    Pure (Just _) field -> do+        val <- env path+        let x = evalField method val field+        return $ (pure x, [(path, v) | v <- val])++    App _ x y -> do+        (x', inp1) <- eval' path method env x+        (y', inp2) <- eval' path method env y+        return (x' <*> y', inp1 ++ inp2)++    Map f x -> do+        (x', inp) <- eval' context method env x+        x''       <- bindResult (return x') (f >=> return . ann path)+        return (x'', inp)++  where+    path = context ++ maybeToList (getRef form)++formMapView :: Monad m => (v -> w) -> Form v m a -> Form w m a+formMapView f (Pure r x)  = Pure r (fieldMapView f x)+formMapView f (App r x y) = App r (formMapView f x) (formMapView f y)+formMapView f (Map g x)   = Map (g >=> return . resultMapError f) (formMapView f x)++-- | Utility: bind for 'Result' inside another monad+bindResult :: Monad m+           => m (Result v a) -> (a -> m (Result v b)) -> m (Result v b)+bindResult mx f = do+    x <- mx+    case x of+        Error errs  -> return $ Error errs+        Success x'  -> f x'

@@ -1,208 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,-             NoMonomorphismRestriction #-}-module Text.Digestive.Forms-    ( FormInput (..)-    , inputString-    , inputText-    , inputRead-    , inputBool-    , inputChoice-    , inputChoices-    , inputFile-    , inputList-    ) where--import Control.Applicative ((<$>))-import Control.Monad (liftM, mplus)-import Control.Monad.State (put, get)-import Control.Monad.Trans (lift)-import Data.Monoid (Monoid, mappend, mconcat)-import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)--import Data.Text (Text)-import qualified Data.Text as T (pack, empty)--import Text.Digestive.Common-import Text.Digestive.Types-import Text.Digestive.Result-import Text.Digestive.Transform---- | Class which all backends should implement. @i@ 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-    getInputString = listToMaybe . getInputStrings--    -- | Should be implemented-    ---    getInputStrings :: i -> [String]--    -- | Parse the input value into 'Text'-    ---    getInputText :: i -> Maybe Text-    getInputText = listToMaybe . getInputTexts--    -- | Can be overriden for efficiency concerns-    ---    getInputTexts :: i -> [Text]-    getInputTexts = map T.pack . getInputStrings--    -- | 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 def = (getInputString =<< inp) `mplus` def-    toResult = Ok . fromMaybe "" . (getInputString =<<)--inputText :: (Monad m, Functor m, FormInput i f)-            => (FormId -> Maybe Text -> v)    -- ^ View constructor-            -> Maybe Text                     -- ^ Default value-            -> Form m i e v Text              -- ^ Resulting form-inputText = input toView toResult-  where-    toView _ inp def = (getInputText =<< inp) `mplus` def-    toResult = Ok . fromMaybe T.empty . (getInputText =<<)--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-        | isInput   = readBool (getInputString =<< inp)-        | otherwise = def-    toResult inp = Ok $ readBool (getInputString =<< inp)-    readBool (Just x) = not $ null x-    readBool _        = 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'), return (Ok inp))-  where-    ids id' = map (((show id' ++ "-") ++) . show) [1 .. length choices]-    toView' id' inp key x = toView id' key (inp == x) x---- An input element that allows multiple selections, such as--- checkboxes or multiple-select boxes.------ When multiple results are submitted, they should all have the same--- name attribute.-inputChoices :: (Monad m, Functor m, FormInput i f, Monoid v, Eq a)-            => (FormId -> String -> Bool -> a -> v)  -- ^ Choice constructor-            -> [a]                                   -- ^ Default choices-            -> [a]                                   -- ^ Choices-            -> Form m i e v [a]                      -- ^ Resulting form-inputChoices toView defaults choices = Form $ do-    inputKeys <- maybe [] getInputStrings <$> getFormInput-    id' <- getFormId-    formInput <- isFormInput-    let -- Find the actual input, based on the key, or use the default input-        inps = if formInput -               then mapMaybe (\inputKey -> lookup inputKey $ zip (ids id') choices) inputKeys-               else defaults-        -- Apply the toView' function to all choices-        view' = mconcat $ zipWith (toView' id' inps) (ids id') choices-    return (View (const view'), return (Ok inps))-  where-    ids id' = map (((show id' ++ "-") ++) . show) [1 .. length choices]-    toView' id' inps key x = toView id' key (x `elem` inps) 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'--up :: Monad m => Int -> FormState m i ()-up n = do-    FormRange s _ <- get-    put $ unitRange $ mapId ((!!n) . iterate tail) s--down :: Monad m => Int -> FormState m i ()-down n = do-    FormRange s _ <- get-    put $ unitRange $ mapId ((!!n) . iterate (0:)) s---- | Converts a formlet representing a single item into a formlet representing a--- dynamically sized list of those items.  It requires that the user specify a--- formlet to hold the length of the list.  Typically this will be a hidden--- field that is automatically updated by client-side javascript.------ The field names must be generated as follows.  Assume that if inputList had--- not been used, the field name would have been prefix-f5.  In this case, the--- list length field name will be prefix-f5.  The first item in the list will--- receive field names starting at prefix-f5.0.0.  If each item is a composed--- form with two fields, those fields will have the names prefix-f5.0.0 and--- prefix-f5.0.1.  The field names for the second item will be prefix-f5.1.0--- and prefix-f5.1.1.----inputList :: (Monad m, Monoid v)-          => Formlet m i e v Int  -- ^ A formlet for the list length-          -> Formlet m i e v a    -- ^ The formlet for a single list element-          -> Formlet m i e v [a]  -- ^ The dynamic list formlet-inputList countField single defaults = Form $ do-    let defCount = maybe 1 length defaults-    (countView, mcountRes) <- unForm $ countField (Just defCount)--    -- We need to evaluate the count-    countRes <- lift $ lift mcountRes-    let count = fromMaybe defCount (getResult countRes)--        -- Use the provided defaults, then loop Nothing-        defaults' = map Just (fromMaybe [] defaults) ++ repeat Nothing--        -- Apply the single form to the defaults-        forms = zipWith ($) (replicate count single) defaults'-    down 2-    list <- mapM (incAfter . unForm) forms-    up 2--    return ( countView `mappend` (mconcat $ map fst list)-           , liftM (combineResults [] []) . sequence $ map snd list-           )-  where-    incAfter k = do-        res <- k-        up 1 >> incState >> down 1-        return res--    combineResults es os [] =-        case es of-            [] -> Ok $ reverse os-            _  -> Error es-    combineResults es os (r:rs) =-        case r of-            Error es' -> combineResults (es ++ es') os rs-            Ok o      -> combineResults es (o:os) rs

@@ -1,133 +0,0 @@--- | General functions for forms that are rendered to some sort of HTML----module Text.Digestive.Forms.Html-    ( FormHtmlConfig (..)-    , FormEncType (..)-    , FormHtml (..)-    , createFormHtml-    , createFormHtmlWith-    , viewHtml-    , mapViewHtml-    , applyClasses-    , defaultHtmlConfig-    , emptyHtmlConfig-    , renderFormHtml-    , renderFormHtmlWith-    ) where--import Data.Monoid (Monoid (..))-import Data.List (intercalate)-import Control.Applicative ((<*>), pure)-import Control.Arrow ((&&&))--import Text.Digestive.Types (Form, mapView, view)---- | 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--instance Functor FormHtml where-    fmap f (FormHtml e g) = FormHtml e (f . 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---- | A shortcut for inserting HTML to the view, defined as a combination of--- 'view' and 'createFormHtml'----viewHtml :: Monad m => a -> Form m i e (FormHtml a) ()-viewHtml = view . createFormHtml . const---- | Lifted version of 'mapView'----mapViewHtml :: (Monad m, Functor m)-            => (v -> w)                   -- ^ Map over the contained HTML-            -> Form m i e (FormHtml v) a  -- ^ Initial form-            -> Form m i e (FormHtml w) a  -- ^ Resulting form-mapViewHtml f = mapView $ \(FormHtml e h) -> FormHtml e (f . h)---- | 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

@@ -1,113 +0,0 @@--- | Module for the core result type, and related functions----module Text.Digestive.Result-    ( Result (..)-    , getResult-    , FormId-    , zeroId-    , mapId-    , formIdList-    , FormRange (..)-    , incrementFormId-    , unitRange-    , isInRange-    , isSubRange-    , retainErrors-    , retainChildErrors-    ) where--import Control.Applicative (Applicative (..))-import Data.List (intercalate)---- | 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--getResult :: Result e ok -> Maybe ok-getResult (Error _) = Nothing-getResult (Ok r) = Just r---- | An ID used to identify forms----data FormId = FormId-    { -- | Global prefix for the form-      formPrefix :: String-    , -- | Stack indicating field. Head is most specific to this item-      formIdList :: [Integer]-    } deriving (Eq, Ord)---- | The zero ID, i.e. the first ID that is usable----zeroId :: String -> FormId-zeroId p = FormId-    { formPrefix = p-    , formIdList = [0]-    }--mapId :: ([Integer] -> [Integer]) -> FormId -> FormId-mapId f (FormId p is) = FormId p $ f is--instance Show FormId where-    show (FormId p xs) =-        p ++ "-fval[" ++ (intercalate "." $ reverse $ map show xs) ++ "]"--formId :: FormId -> Integer-formId = head . formIdList---- | 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:xs)) = FormId p $ (x + 1):xs-incrementFormId (FormId _ []) = error "Bad FormId list"--unitRange :: FormId -> FormRange-unitRange i = FormRange i $ incrementFormId i---- | 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 a (FormRange b c) = formId a >= formId b && formId 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,91 +0,0 @@--- | Optionally failing transformers for forms----module Text.Digestive.Transform-    ( Transformer (..)-    , transform-    , transformFormlet-    , transformEither-    , transformEitherM-    , transformRead-    , required-    ) where--import Prelude hiding ((.), id)--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-    (v, r) <- unForm form-    range <- getFormRange-    return (v, r >>= transform' range)-  where-    -- We already have an error, cannot continue-    transform' _     (Error e) = return (Error e)-    -- Apply transformer-    transform' range (Ok x)    = do-        ex <- unTransformer transformer x-        return $ case ex of-            -- Attach the range information to the errors-            Left e   -> Error $ map ((,) range) e-            -- All fine-            Right x' -> Ok x'---- | Apply a transformer to a formlet----transformFormlet :: Monad m-                 => (b -> a)             -- ^ Needed to produce defaults-                 -> Formlet m i e v a    -- ^ Formlet to transform-                 -> Transformer m e a b  -- ^ Transformer-                 -> Formlet m i e v b    -- ^ Resulting formlet-transformFormlet f formlet transformer def =-    formlet (fmap f def) `transform` transformer---- | 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'---- | A transformer that converts 'Maybe a' to 'a'.-required :: (Monad m) => -            e  -- ^ error to return if value is 'Nothing'-         -> Transformer m e (Maybe a) a-required err = transformEither $ maybe (Left err) Right

@@ -1,232 +1,70 @@--- | Core types----{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-} module Text.Digestive.Types-    ( View (..)-    , Environment (..)-    , fromList-    , FormState-    , getFormId-    , getFormRange-    , getFormInput-    , getFormInput'-    , isFormInput-    , Form (..)-    , Formlet-    , bracketState-    , incState-    , view-    , (++>)-    , (<++)-    , mapView-    , runForm-    , runViewForm-    , eitherForm-    , viewForm+    ( Result (..)+    , resultMapError+    , Path+    , toPath+    , fromPath+    , Method (..)+    , FormInput (..)+    , Env     ) where -import Data.Monoid (Monoid (..))-import Control.Arrow (first)-import Control.Monad (liftM, 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 = getFormId >>= getFormInput'---- | Gets the input of an arbitrary FormId.----getFormInput' :: Monad m => FormId -> FormState m i (Maybe i)-getFormInput' id' = do-    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, m (Result e a))-    }---- | A function for generating forms with an optional default value.----type Formlet m i e v a = Maybe a -> Form m i e v a--instance Monad m => Functor (Form m i e v) where-    fmap f form = Form $ do-        (view', result) <- unForm form-        return (view', liftM (fmap f) result)--instance (Monad m, Monoid v) => Applicative (Form m i e v) where-    pure x = Form $ return (mempty, return (return x))-    f1 <*> f2 = Form $ do-        -- Assuming f1 already has a valid ID-        ((v1,r1), (v2,r2)) <- bracketState $ do-            res1 <- unForm f1-            incState-            res2 <- unForm f2-            return (res1, res2)-        return (v1 `mappend` v2, liftM2 (<*>) r1 r2)+import Data.Monoid (Monoid, mappend) -bracketState :: Monad m => FormState m i a -> FormState m i a-bracketState k = do-    FormRange startF1 _ <- get-    res <- k-    FormRange _ endF2 <- get-    put $ FormRange startF1 endF2-    return res+import Data.Text (Text)+import qualified Data.Text as T -incState :: Monad m => FormState m i ()-incState = do-        FormRange _ endF1 <- get-        put $ unitRange endF1+-- | A mostly internally used type for representing Success/Error, with a+-- special applicative instance+data Result v a+    = Success a+    | Error v+    deriving (Show) --- | 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'), return (Ok ()))+instance Functor (Result v) where+    fmap f (Success x) = Success (f x)+    fmap _ (Error x)   = Error x --- | 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)+instance Monoid v => Applicative (Result v) where+    pure x                  = Success x+    Error x   <*> Error y   = Error $ mappend x y+    Error x   <*> Success _ = Error x+    Success _ <*> Error y   = Error y+    Success x <*> Success y = Success (x y) -infixl 6 ++>+instance Monad (Result v) where+    return x          = Success x+    (Error x)   >>= _ = Error x+    (Success x) >>= f = f x --- | 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)+-- | Map over the error type of a 'Result'+resultMapError :: (v -> w) -> Result v a -> Result w a+resultMapError f (Error x)   = Error (f x)+resultMapError _ (Success x) = Success x -infixr 5 <+++-- | Describes a path to a subform+type Path = [Text] --- | 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+-- | Create a 'Path' from some text+toPath :: Text -> Path+toPath = filter (not . T.null) . T.split (== '.') --- | 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, m (Result e a))  -- ^ Result-runForm form id' env = evalStateT (runReaderT (unForm form) env) $-    unitRange $ zeroId id'+-- | Serialize a 'Path' to 'Text'+fromPath :: Path -> Text+fromPath = T.intercalate "." --- | 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', mresult) <- runForm form id' env-    result <- mresult-    return $ case result of-        Error e  -> Left $ unView view' e-        Ok x     -> Right x+-- | The HTTP methods+data Method = Get | Post+    deriving (Eq, Ord, Show) --- | Evaluate a form, return view and a result if successful-runViewForm :: Monad m-            => Form m i e v a-            -> String-            -> Environment m i-            -> m (v, Maybe a)-runViewForm form id' env = do-    (view', mresult) <- runForm form id' env-    result <- mresult-    return $ case result of-        Error e -> (unView view' e, Nothing)-        Ok x    -> (unView view' [], Just x)+-- | The different input types sent by the browser+data FormInput+    = TextInput Text+    | FileInput FilePath+    deriving (Show) --- | 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' []+-- | An environment (e.g. a server) from which we can read input parameters. A+-- single key might be associated with multiple text values (multi-select).+type Env m = Path -> m [FormInput]

@@ -0,0 +1,9 @@+module Text.Digestive.Util+    ( readMaybe+    ) where++-- | 'read' in the 'Maybe' monad.+readMaybe :: Read a => String -> Maybe a+readMaybe str = case readsPrec 1 str of+    [(x, "")] -> Just x+    _         -> Nothing

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

@@ -0,0 +1,148 @@+{-# LANGUAGE ExistentialQuantification, GADTs, OverloadedStrings,+        ScopedTypeVariables #-}+module Text.Digestive.View+    ( View (..)++      -- * Obtaining a view+    , getForm+    , postForm++      -- * Operations on views+    , subView++      -- * Querying a view+      -- ** Low-level+    , absolutePath++      -- ** Form encoding+    , viewEncType++      -- ** Input+    , fieldInputText+    , fieldInputChoice+    , fieldInputBool+    , fieldInputFile++      -- ** Errors+    , errors+    , childErrors+    ) where++import Control.Arrow (second)+import Data.List (findIndex, isPrefixOf)+import Data.Maybe (fromMaybe)++import Data.Text (Text)++import Text.Digestive.Field+import Text.Digestive.Form.Encoding+import Text.Digestive.Form.Internal+import Text.Digestive.Types++data View v = forall a m. Monad m => View+    { viewName    :: Text+    , viewContext :: Path+    , viewForm    :: Form v m a+    , viewInput   :: [(Path, FormInput)]+    , viewErrors  :: [(Path, v)]+    , viewMethod  :: Method+    }++instance Functor View where+    fmap f (View name ctx form input errs method) = View+        name ctx (formMapView f form) input (map (second f) errs) method++instance Show v => Show (View v) where+    show (View name ctx form input errs method) =+        "View " ++ show name ++ " " ++ show ctx ++ " " ++ show form ++ " " +++        show input ++ " " ++ show errs ++ " " ++ show method++getForm :: Monad m => Text -> Form v m a -> View v+getForm name form = View name [] form [] [] Get++postForm :: Monad m => Text -> Form v m a -> Env m -> m (View v, Maybe a)+postForm name form env = eval Post env' form >>= \(r, inp) -> return $ case r of+    Error errs -> (View name [] form inp errs Post, Nothing)+    Success x  -> (View name [] form inp [] Post, Just x)+  where+    env' = env . (name :)++subView :: Text -> View v -> View v+subView ref (View name ctx form input errs method) =+    View name (ctx ++ path) form input errs method+  where+    path = toPath ref++-- | Determine an absolute 'Path' for a field in the form+absolutePath :: Text -> View v -> Path+absolutePath ref view@(View name _ _ _ _ _) = name : viewPath ref view++-- | Internal version of 'absolutePath' which does not take the form name into+-- account+viewPath :: Text -> View v -> Path+viewPath ref (View _ ctx _ _ _ _) = ctx ++ toPath ref++viewEncType :: View v -> FormEncType+viewEncType (View _ _ form _ _ _) = formEncType form++lookupInput :: Path -> [(Path, FormInput)] -> [FormInput]+lookupInput path = map snd . filter ((== path) . fst)++fieldInputText :: forall v. Text -> View v -> Text+fieldInputText ref view@(View _ _ form input _ method) =+    queryField path form eval'+  where+    path       = viewPath ref view+    givenInput = lookupInput path input++    eval' :: Field v b -> Text+    eval' field = case field of+        Text t -> evalField method givenInput (Text t)+        _      -> ""  -- TODO: perhaps throw error?++fieldInputChoice :: forall v. Text -> View v -> ([v], Int)+fieldInputChoice ref view@(View _ _ form input _ method) =+    queryField path form eval'+  where+    path       = viewPath ref view+    givenInput = lookupInput path input++    eval' :: Field v b -> ([v], Int)+    eval' field = case field of+        Choice xs i ->+            let x   = evalField method givenInput (Choice xs i)+                idx = fromMaybe 0 $ findIndex (== x) (map fst xs)+            in (map snd xs, idx)+        _           -> ([], 0)  -- TODO: perhaps throw error?++fieldInputBool :: forall v. Text -> View v -> Bool+fieldInputBool ref view@(View _ _ form input _ method) =+    queryField path form eval'+  where+    path       = viewPath ref view+    givenInput = lookupInput path input++    eval' :: Field v b -> Bool+    eval' field = case field of+        Bool x -> evalField method givenInput (Bool x)+        _      -> False  -- TODO: perhaps throw error?++fieldInputFile :: forall v. Text -> View v -> Maybe FilePath+fieldInputFile ref view@(View _ _ form input _ method) =+    queryField path form eval'+  where+    path       = viewPath ref view+    givenInput = lookupInput path input++    eval' :: Field v b -> Maybe FilePath+    eval' field = case field of+        File -> evalField method givenInput File+        _    -> Nothing  -- TODO: perhaps throw error?++errors :: Text -> View v -> [v]+errors ref view = map snd $ filter ((== viewPath ref view) . fst) $+    viewErrors view++childErrors :: Text -> View v -> [v]+childErrors ref view = map snd $+    filter ((viewPath ref view `isPrefixOf`) . fst) $ viewErrors view

@@ -0,0 +1,16 @@+module Main+    ( main+    ) where++import Test.Framework (defaultMain)++import qualified Text.Digestive.Field.Tests (tests)+import qualified Text.Digestive.Form.Encoding.Tests (tests)+import qualified Text.Digestive.View.Tests (tests)++main :: IO ()+main = defaultMain+    [ Text.Digestive.Field.Tests.tests+    , Text.Digestive.Form.Encoding.Tests.tests+    , Text.Digestive.View.Tests.tests+    ]