digestive-functors 0.2.1.0 → 0.8.4.2
raw patch · 29 files changed
Files
- CHANGELOG +57/−0
- digestive-functors.cabal +105/−24
- src/Text/Digestive.hs +22/−9
- src/Text/Digestive/Cli.hs +0/−196
- src/Text/Digestive/Common.hs +0/−46
- src/Text/Digestive/Form.hs +621/−0
- src/Text/Digestive/Form/Encoding.hs +77/−0
- src/Text/Digestive/Form/Internal.hs +421/−0
- src/Text/Digestive/Form/Internal/Field.hs +107/−0
- src/Text/Digestive/Form/List.hs +75/−0
- src/Text/Digestive/Forms.hs +0/−208
- src/Text/Digestive/Forms/Html.hs +0/−133
- src/Text/Digestive/Ref.hs +31/−0
- src/Text/Digestive/Result.hs +0/−113
- src/Text/Digestive/Transform.hs +0/−91
- src/Text/Digestive/Types.hs +72/−204
- src/Text/Digestive/Util.hs +15/−0
- src/Text/Digestive/Validate.hs +0/−62
- src/Text/Digestive/View.hs +337/−0
- tests/TestSuite.hs +26/−0
- tests/Text/Digestive/Field/QTests.hs +70/−0
- tests/Text/Digestive/Field/Tests.hs +36/−0
- tests/Text/Digestive/Form/Encoding/QTests.hs +49/−0
- tests/Text/Digestive/Form/Encoding/Tests.hs +35/−0
- tests/Text/Digestive/Form/List/QTests.hs +25/−0
- tests/Text/Digestive/Form/QTests.hs +108/−0
- tests/Text/Digestive/Tests/Fixtures.hs +262/−0
- tests/Text/Digestive/Types/QTests.hs +48/−0
- tests/Text/Digestive/View/Tests.hs +208/−0
+ CHANGELOG view
@@ -0,0 +1,57 @@+- 0.8.4.2 (2020-05-09)+ * Bump `Cabal` lower bound to 1.10++- 0.8.4.1 (2020-05-09)+ * Bump `semigroups` dependency upper bound to 0.20++- 0.8.4.0 (2017-07-18)+ * GHC 8.4 support+ * Bump `containers` to 0.6+ * Bump `time` to 1.9+ * Bump `QuickCheck` to 2.11++- 0.8.3.0 (2017-12-26)+ * Fix input element values for choice forms+ * Bump `time` to 1.8+ * Bump `HUnit` to 1.6+ * Bump `QuickCheck` to 2.10++- 0.8.2.0+ * Update `QuickCheck` version bound+ * Updated CHoice type to allow for multiple choices++- 0.8.1.1+ * Bump `time` dependency to allow up to `time-1.6`++- 0.8.1.0+ * Add support for a list of files via `<input type="file" multiple />`++- 0.8.0.1+ * Bump `HUnit` dependency to allow up to `HUnit-1.3`++- 0.8.0.0+ * Lots of constraint changes due to Applicative => Monad++- 0.7.1.5+ * Bump `time` dependency to allow up to `time-1.5`, for tests as well+ * Bump `QuickCheck` dependency to allow up to `QuickCheck-2.8`++- 0.7.1.4+ * Bump `time` dependency to allow up to `time-1.5`++- 0.7.1.3+ * Bump `text` dependency again++- 0.7.1.2+ * Bump `text` dependency to allow up to `text-1.3`++- 0.7.1.1+ * Bump `QuickCheck` dependency to allow `QuickCheck-2.7`+ * Clean warnings in tests compilation+ * Don't use `Text.Read` to fix compilation on GHC 7.4++- 0.7.1.0+ * Add `validateOptional` function+ * Add `condition` functions to allow composing multiple independent+ validation functions+ * Bump `text` dependency to allow `text-1.1`
digestive-functors.cabal view
@@ -1,39 +1,120 @@ Name: digestive-functors-Version: 0.2.1.0-Synopsis: A general way to consume input using applicative functors+Version: 0.8.4.2+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.10 +Extra-source-files:+ CHANGELOG+ Library- Hs-source-dirs: src- Ghc-options: -Wall+ Default-language: Haskell2010+ Hs-source-dirs: src+ Ghc-options: -Wall -fwarn-tabs+ Default-extensions: CPP - Exposed-modules: - Text.Digestive.Validate,- Text.Digestive.Common,- Text.Digestive.Types,- Text.Digestive.Transform,- Text.Digestive.Forms,- Text.Digestive.Forms.Html,- Text.Digestive.Result,- Text.Digestive.Cli,+ Exposed-modules: Text.Digestive+ Text.Digestive.Form+ Text.Digestive.Form.Encoding+ Text.Digestive.Form.List+ Text.Digestive.Ref+ Text.Digestive.Types+ Text.Digestive.Util+ Text.Digestive.View+ Text.Digestive.Form.Internal+ Text.Digestive.Form.Internal.Field Build-depends:- base >= 4 && < 5,- bytestring >= 0.9,- containers >= 0.3,- mtl >= 1.1.0.0 && < 3,- text >= 0.10+ base >= 4 && < 5,+ bytestring >= 0.9 && < 0.11,+ containers >= 0.3 && < 0.7,+ mtl >= 1.1.0.0 && < 3,+ old-locale >= 1.0 && < 1.1,+ semigroups >= 0.16 && < 0.20,+ text >= 0.10 && < 1.3,+ time >= 1.4 && < 1.10++Test-suite digestive-functors-tests+ Default-language: Haskell2010+ Type: exitcode-stdio-1.0+ Hs-source-dirs: src tests+ Main-is: TestSuite.hs+ Ghc-options: -Wall++ Other-modules:+ Text.Digestive.Field.QTests+ Text.Digestive.Field.Tests+ Text.Digestive.Form+ Text.Digestive.Form.Encoding+ Text.Digestive.Form.Encoding.QTests+ Text.Digestive.Form.Encoding.Tests+ Text.Digestive.Form.Internal+ Text.Digestive.Form.Internal.Field+ Text.Digestive.Form.List+ Text.Digestive.Form.List.QTests+ Text.Digestive.Form.QTests+ Text.Digestive.Ref+ Text.Digestive.Tests.Fixtures+ Text.Digestive.Types+ Text.Digestive.Types.QTests+ Text.Digestive.Util+ Text.Digestive.View+ Text.Digestive.View.Tests++ Build-depends:+ HUnit >= 1.2 && < 1.7,+ QuickCheck >= 2.5 && < 2.12,+ test-framework >= 0.4 && < 0.9,+ test-framework-hunit >= 0.3 && < 0.4,+ test-framework-quickcheck2 >= 0.3 && < 0.4,+ -- Copied from regular dependencies:+ base >= 4 && < 5,+ bytestring >= 0.9 && < 0.11,+ containers >= 0.3 && < 0.7,+ mtl >= 1.1.0.0 && < 3,+ old-locale >= 1.0 && < 1.1,+ semigroups >= 0.16 && < 0.19,+ text >= 0.10 && < 1.3,+ time >= 1.4 && < 1.10++Source-repository head+ Type: git+ Location: https://github.com/jaspervdj/digestive-functors
src/Text/Digestive.hs view
@@ -1,13 +1,26 @@--- | 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+-- | End-user interface - provides form construction functionality+ , module Text.Digestive.Form.Encoding+-- | Functionality related to content type attributes of forms+ , module Text.Digestive.Ref+-- | Utilities for string conversion and encoding - field referencing , module Text.Digestive.Types- , module Text.Digestive.Transform- , module Text.Digestive.Validate+-- | Core non-internal types+ , module Text.Digestive.View+-- | Functionality for front-end interfacing ) where -import Text.Digestive.Result-import Text.Digestive.Types-import Text.Digestive.Transform-import Text.Digestive.Validate++--------------------------------------------------------------------------------+import Text.Digestive.Form+import Text.Digestive.Form.Encoding+import Text.Digestive.Ref+import Text.Digestive.Types+import Text.Digestive.View+++
− src/Text/Digestive/Cli.hs
@@ -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
− src/Text/Digestive/Common.hs
@@ -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 ()))
+ src/Text/Digestive/Form.hs view
@@ -0,0 +1,621 @@+--------------------------------------------------------------------------------+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+-- | End-user interface - provides the main functionality for+-- form creation and validation. For an interface for front-end+-- implementation, see "View".+module Text.Digestive.Form+ ( Formlet+ , Form+ , SomeForm (..)+ , (.:)++ -- * Basic forms+ , text+ , string+ , stringRead+ , choice+ , choice'+ , choiceWith+ , choiceWith'+ , choiceMultiple+ , choiceMultiple'+ , choiceWithMultiple+ , choiceWithMultiple'+ , groupedChoice+ , groupedChoice'+ , groupedChoiceWith+ , groupedChoiceWith'+ , groupedChoiceMultiple+ , groupedChoiceMultiple'+ , groupedChoiceWithMultiple+ , groupedChoiceWithMultiple'+ , bool+ , file+ , fileMultiple++ -- * Optional forms+ , optionalText+ , optionalString+ , optionalStringRead++ -- * Date/time forms+ , utcTimeFormlet+ , localTimeFormlet+ , dateFormlet+ , timeFormlet+ , optionalUtcTimeFormlet+ , optionalLocalTimeFormlet+ , optionalDateFormlet+ , optionalTimeFormlet++ -- * Validation and transformation+ , check+ , checkM+ , validate+ , validateOptional+ , validateM+ , conditions+ , disable++ -- * Lifting forms+ , monadic++ -- * Dynamic list forms+ , listOf+ ) where+++--------------------------------------------------------------------------------+import Control.Applicative+import Control.Monad (liftM, liftM2)+import Data.List (findIndex)+import Data.Maybe (fromMaybe, listToMaybe, catMaybes)+import Data.Monoid (Monoid)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Time+#if !MIN_VERSION_time(1,5,0)+import System.Locale+#endif+import Prelude+++--------------------------------------------------------------------------------+import Text.Digestive.Form.Internal+import Text.Digestive.Form.Internal.Field+import Text.Digestive.Form.List+import Text.Digestive.Ref+import Text.Digestive.Types+import Text.Digestive.Util+++--------------------------------------------------------------------------------+-- | A 'Form' with a set, optional default value+type Formlet v m a = Maybe a -> Form v m a+++--------------------------------------------------------------------------------+-- | Returns a 'Formlet' which may optionally take a default text+text :: (Monad m, Monoid v) => Formlet v m Text+text def = Pure $ Text $ fromMaybe "" def+++--------------------------------------------------------------------------------+-- | Identical to "text" but takes a String+string :: (Monad m, Monoid v) => Formlet v m String+string = fmap T.unpack . text . fmap T.pack+++--------------------------------------------------------------------------------+-- | Returns a 'Formlet' for a parseable and serializable value type+stringRead :: (Monad m, Monoid v, Read a, Show a) => v -> Formlet v m a+stringRead err = transform (readTransform err) . string . fmap show+++--------------------------------------------------------------------------------+-- | Returns a 'Formlet' for a value restricted to a single value from+-- the provided list of value-message tuples+choice :: (Eq a, Monad m, Monoid v) => [(a, v)] -> Formlet v m a+choice items def = choiceWith (zip makeRefs items) def+++--------------------------------------------------------------------------------+-- | Sometimes there is no good 'Eq' instance for 'choice'. In this case, you+-- can use this function, which takes an index in the list as default.+choice' :: (Monad m, Monoid v) => [(a, v)] -> Maybe Int -> Form v m a+choice' items def = choiceWith' (zip makeRefs items) def+++--------------------------------------------------------------------------------+-- | Allows you to assign your own values: these values will be used in the+-- resulting HTML instead of the default @[0 ..]@. This fixes some race+-- conditions that might otherwise appear, e.g. if new choice items are added to+-- some database while a user views and submits the form...+choiceWith+ :: (Eq a, Monad m, Monoid v) => [(Text, (a, v))] -> Formlet v m a+choiceWith items def = choiceWith' items def'+ where+ def' = def >>= (\d -> findIndex ((== d) . fst . snd) items)+++--------------------------------------------------------------------------------+-- | A version of 'choiceWith' for when there is no good 'Eq' instance.+choiceWith'+ :: (Monad m, Monoid v) => [(Text, (a, v))] -> Maybe Int -> Form v m a+choiceWith' [] _ = error "choice expects a list with at least one item in it"+choiceWith' items def = fromMaybe defaultItem . listToMaybe . map fst <$> (Pure $ Choice [("", items)] [def'])+ where+ defaultItem = fst $ snd $ items !! def'+ def' = fromMaybe 0 def+++--------------------------------------------------------------------------------+-- | Returns a 'Formlet' for a value restricted to multiple values from+-- the provided list of value-message tuples. Intended for use with the+-- @multiple@ attribute for select elements. Allows for an empty result.+choiceMultiple :: (Eq a, Monad m, Monoid v) => [(a, v)] -> Formlet v m [a]+choiceMultiple items def = choiceWithMultiple (zip makeRefs items) def+++--------------------------------------------------------------------------------+-- | Sometimes there is no good 'Eq' instance for 'choice'. In this case, you+-- can use this function, which takes an index in the list as default.+choiceMultiple' :: (Monad m, Monoid v) => [(a, v)] -> Maybe [Int] -> Form v m [a]+choiceMultiple' items def = choiceWithMultiple' (zip makeRefs items) def+++--------------------------------------------------------------------------------+-- | Allows you to assign your own values: these values will be used in the+-- resulting HTML instead of the default @[0 ..]@. This fixes some race+-- conditions that might otherwise appear, e.g. if new choice items are added to+-- some database while a user views and submits the form...+choiceWithMultiple+ :: (Eq a, Monad m, Monoid v) => [(Text, (a, v))] -> Formlet v m [a]+choiceWithMultiple items def = choiceWithMultiple' items def'+ where+ def' = def >>= Just . catMaybes . map (\d -> findIndex ((== d) . fst . snd) items)+++--------------------------------------------------------------------------------+-- | A version of 'choiceWithMultiple' for when there is no good 'Eq' instance.+choiceWithMultiple'+ :: (Monad m, Monoid v) => [(Text, (a, v))] -> Maybe [Int] -> Form v m [a]+choiceWithMultiple' items def = map fst <$> (Pure $ Choice [("", items)] def')+ where+ def' = fromMaybe [] def+++--------------------------------------------------------------------------------+-- | Returns a 'Formlet' for a single value from named groups of choices.+groupedChoice+ :: (Eq a, Monad m, Monoid v) => [(Text, [(a, v)])] -> Formlet v m a+groupedChoice items def =+ groupedChoiceWith (mkGroupedRefs items makeRefs) def+++--------------------------------------------------------------------------------+-- | Sometimes there is no good 'Eq' instance for 'choice'. In this case, you+-- can use this function, which takes an index in the list as default.+groupedChoice'+ :: (Monad m, Monoid v) => [(Text, [(a, v)])] -> Maybe Int -> Form v m a+groupedChoice' items def =+ groupedChoiceWith' (mkGroupedRefs items makeRefs) def+++--------------------------------------------------------------------------------+mkGroupedRefs :: [(Text, [a])]+ -> [Text]+ -> [(Text, [(Text, a)])]+mkGroupedRefs [] _ = []+mkGroupedRefs (g:gs) is = cur : mkGroupedRefs gs b+ where+ (a,b) = splitAt (length $ snd g) is+ cur = (fst g, zip a (snd g))+++--------------------------------------------------------------------------------+-- | Allows you to assign your own values: these values will be used in the+-- resulting HTML instead of the default @[0 ..]@. This fixes some race+-- conditions that might otherwise appear, e.g. if new choice items are added to+-- some database while a user views and submits the form...+groupedChoiceWith :: (Eq a, Monad m, Monoid v)+ => [(Text, [(Text, (a, v))])]+ -> Formlet v m a+groupedChoiceWith items def = groupedChoiceWith' items def'+ where+ def' = def >>= (\d -> findIndex ((== d) . fst . snd) $+ concat $ map snd items)+++--------------------------------------------------------------------------------+-- | Low-level support for grouped choice.+groupedChoiceWith' :: (Monad m, Monoid v)+ => [(Text, [(Text, (a, v))])]+ -> Maybe Int+ -> Form v m a+groupedChoiceWith' items def =+ case concatMap snd items of+ [] -> error "groupedChoice expects a list with at least one item in it"+ _ -> head . map fst <$> (Pure $ Choice items def')+ where+ def' = case def of+ Just x -> [x]+ Nothing -> [0]+++--------------------------------------------------------------------------------+-- | Returns a 'Formlet' for multiple values from named groups of choices.+-- Intended for use with the @multiple@ attribute for select elements that+-- have optgroups. Allows for an empty result.+groupedChoiceMultiple+ :: (Eq a, Monad m, Monoid v) => [(Text, [(a, v)])] -> Formlet v m [a]+groupedChoiceMultiple items def =+ groupedChoiceWithMultiple (mkGroupedRefs items makeRefs) def+++--------------------------------------------------------------------------------+-- | Sometimes there is no good 'Eq' instance for 'choice'. In this case, you+-- can use this function, which takes an index in the list as default.+groupedChoiceMultiple'+ :: (Monad m, Monoid v) => [(Text, [(a, v)])] -> Maybe [Int] -> Form v m [a]+groupedChoiceMultiple' items def =+ groupedChoiceWithMultiple' (mkGroupedRefs items makeRefs) def+++--------------------------------------------------------------------------------+-- | Allows you to assign your own values: these values will be used in the+-- resulting HTML instead of the default @[0 ..]@. This fixes some race+-- conditions that might otherwise appear, e.g. if new choice items are added to+-- some database while a user views and submits the form...+groupedChoiceWithMultiple :: (Eq a, Monad m, Monoid v)+ => [(Text, [(Text, (a, v))])]+ -> Formlet v m [a]+groupedChoiceWithMultiple items def = groupedChoiceWithMultiple' items def'+ where+ def' = def >>= Just . catMaybes . map (\d -> findIndex ((== d) . fst . snd) $+ concat $ map snd items)+++--------------------------------------------------------------------------------+-- | Low-level support for grouped choice.+groupedChoiceWithMultiple' :: (Monad m, Monoid v)+ => [(Text, [(Text, (a, v))])]+ -> Maybe [Int]+ -> Form v m [a]+groupedChoiceWithMultiple' items def = map fst <$> (Pure $ Choice items def')+ where+ def' = case def of+ Just x -> x+ Nothing -> []++--------------------------------------------------------------------------------+-- | Returns a 'Formlet' for binary choices+bool :: (Monad m, Monoid v) => Formlet v m Bool+bool = Pure . Bool . fromMaybe False+++--------------------------------------------------------------------------------+-- | Returns a 'Formlet' for file selection+file :: (Monad m, Monoid v) => Form v m (Maybe FilePath)+file = listToMaybe <$> Pure File+++--------------------------------------------------------------------------------+-- | Returns a 'Formlet' for multiple file selection. Intended for use with+-- the @multiple@ attribute, which allows for multiple files to be uploaded+-- with a single input element.+fileMultiple :: (Monad m, Monoid v) => Form v m [FilePath]+fileMultiple = Pure File+++--------------------------------------------------------------------------------+-- | Validate the results of a form with a simple predicate+--+-- Example:+--+-- > check "Can't be empty" (not . null) (string Nothing)+check :: (Monad m, Monoid v)+ => 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, Monoid v) => 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, Monoid v) => (a -> Result v b) -> Form v m a -> Form v m b+validate = validateM . (return .)++--------------------------------------------------------------------------------+-- | Same as 'validate', but works with forms of the form:+--+-- > Form v m (Maybe a)+--+-- .+--+-- Example: taking the first character of an optional input string+--+-- > head' :: String -> Result String Char+-- > head' [] = Error "Is empty"+-- > head' (x : _) = Success x+-- >+-- > char :: Monad m => Form m String (Maybe Char)+-- > char = validateOptional head' (optionalString Nothing)+validateOptional+ :: (Monad m, Monoid v)+ => (a -> Result v b) -> Form v m (Maybe a) -> Form v m (Maybe b)+validateOptional f = validate (forOptional f)++--------------------------------------------------------------------------------+-- | Version of 'validate' which allows monadic validations+validateM+ :: (Monad m, Monoid v) => (a -> m (Result v b)) -> Form v m a -> Form v m b+validateM = transform++--------------------------------------------------------------------------------+-- | Allows for the composition of independent validation functions.+--+-- For example, let's validate an even integer between 0 and 100:+--+-- > form :: Monad m => Form Text m FormData+-- > ... -- some fields+-- > <*> "smallEvenInteger" .: validate (notEmpty >=> integer >=> even >=> greaterThan 0 >=> lessThanOrEq 100) (text Nothing)+-- > ... -- more fields+--+-- where+--+-- > notEmpty :: IsString v => Text -> Result v Text+-- > integer :: (Integral a, IsString v) => Text -> Result v a+-- > greaterThan 0 :: (Num a, Ord a, Show a) => a -> Result Text a+-- > lessThanOrEq 0 :: (Num a, Ord a, Show a) => a -> Result Text a+-- > even :: Integer -> Result Text Integer+--+-- .+--+-- This will validate our smallEvenInteger correctly, but there is a problem.+-- If a user enters an odd number greater than 100, only+--+-- > "number must be even"+--+--+-- will be returned. It would make for a better user experience if+--+-- > ["number must be even", "number must be less than 100"]+--+-- was returned instead. This can be accomplished by rewriting our form to be:+--+-- > form :: Monad m => Form [Text] m FormData+-- > ... -- some fields+-- > <*> "smallEvenInteger" .: validate (notEmpty >=> integer >=> conditions [even, greaterThan 0, lessThanOrEq 100]) (text Nothing)+-- > ... -- more fields+--+-- .+--+-- If we want to collapse our list of errors into a single 'Text', we can do something like:+--+-- > form :: Monad m => Form Text m FormData+-- > ... -- some fields+-- > <*> "smallEvenInteger" .: validate (notEmpty >=> integer >=> commaSeperated . conditions [even, greaterThan 0, lessThanOrEq 100]) (text Nothing)+-- > ... -- more fields+--+-- where+--+-- > commaSeperated :: (Result [Text] a) -> (Result Text a)+--+-- .+conditions :: [(a -> Result e b)] -- ^ Any 'Success' result of a validation function is provably guaranteed to be discarded. Only 'Error' results are used.+ -> a -- ^ If all validation functions pass, parameter will be re-wrapped with a 'Success'.+ -> (Result [e] a) -- ^ List of errors is guaranteed to be in the same order as inputed validations functions. So,+ --+ -- > conditions [even, greaterThan 0] -1+ --+ -- is specified to return+ --+ -- > Error ["must be even", "must be greater than 0"]+ --+ -- and not+ --+ -- > Error ["must be greater than 0", "must be even"]+ --+ -- .+conditions fs x = result+ where+ result = case (foldr errorCond [] fs) of+ [] -> Success x+ es -> Error es+ errorCond f es = case (f x) of+ Success _ -> es+ Error e -> e:es+++--------------------------------------------------------------------------------+-- | Disables a form+disable :: Form v m a -> Form v m a+disable f = Metadata [Disabled] f+++--------------------------------------------------------------------------------+-- | Create a text form with an optional default text which+-- returns nothing if no optional text was set, and no input+-- was retrieved.+optionalText :: (Monad m, Monoid v) => Maybe Text -> Form v m (Maybe Text)+optionalText def = validate opt (text def)+ where+ opt t+ | T.null t = return Nothing+ | otherwise = return $ Just t+++--------------------------------------------------------------------------------+-- | Identical to 'optionalText', but uses Strings+optionalString :: (Monad m, Monoid v) => Maybe String -> Form v m (Maybe String)+optionalString = fmap (fmap T.unpack) . optionalText . fmap T.pack+++--------------------------------------------------------------------------------+-- | Identical to 'optionalText' for parseable and serializable values.+optionalStringRead :: (Monad m, Monoid v, Read a, Show a)+ => v -> Maybe a -> Form v m (Maybe a)+optionalStringRead err = transform readTransform' . optionalString . fmap show+ where+ readTransform' (Just s) = liftM (fmap Just) $ readTransform err s+ readTransform' Nothing = return (return Nothing)+++--------------------------------------------------------------------------------+-- Helper function for attempted parsing, with custom error messages+readTransform :: (Monad m, Monoid v, Read a) => v -> String -> m (Result v a)+readTransform err = return . maybe (Error err) return . readMaybe+++--------------------------------------------------------------------------------+-- | Dynamic lists.+--+-- The type is a less restrictive version of:+--+-- > Formlet a -> Formlet [a]+listOf :: (Monad m, Monoid v)+ => (Maybe a -> Form v m b)+ -> (Maybe [a] -> Form v m [b])+listOf single def =+ List (fmap single defList) (indicesRef .: listIndices ixs)++ where+ ixs = case def of+ Nothing -> [0]+ Just xs -> [0 .. length xs - 1]++ defList = DefaultList Nothing $ maybe [] (map Just) def+++--------------------------------------------------------------------------------+-- Manipulatable indices+listIndices :: (Monad m, Monoid v) => [Int] -> Form v m [Int]+listIndices = fmap parseIndices . text . Just . unparseIndices+++------------------------------------------------------------------------------+-- Date/time formlets+------------------------------------------------------------------------------+++utcTimeFormlet :: Monad m+ => String+ -- ^ Date format string+ -> String+ -- ^ Time format string+ -> TimeZone+ -> Formlet Text m UTCTime+utcTimeFormlet dFmt tFmt tz d =+ localTimeToUTC tz <$> localTimeFormlet dFmt tFmt (utcToLocalTime tz <$> d)+++localTimeFormlet :: Monad m+ => String+ -- ^ Date format string+ -> String+ -- ^ Time format string+ -> Formlet Text m LocalTime+localTimeFormlet dFmt tFmt d = LocalTime+ <$> "date" .: dateFormlet dFmt (localDay <$> d)+ <*> "time" .: timeFormlet tFmt (localTimeOfDay <$> d)+++dateFormlet :: Monad m+ => String+ -- ^ Format string+ -> Formlet Text m Day+dateFormlet fmt d =+ validate (vFunc fmt "invalid date") (string $ formatTime defaultTimeLocale fmt <$> d)+++timeFormlet :: Monad m+ => String+ -- ^ Format string+ -> Formlet Text m TimeOfDay+timeFormlet fmt d =+ validate (vFunc fmt "invalid time") (string $ formatTime defaultTimeLocale fmt <$> d)+++optionalUtcTimeFormlet :: Monad m+ => String+ -- ^ Date format string+ -> String+ -- ^ Time format string+ -> TimeZone+ -> Maybe UTCTime+ -> Form Text m (Maybe UTCTime)+optionalUtcTimeFormlet dFmt tFmt tz d =+ liftM (localTimeToUTC tz) <$> optionalLocalTimeFormlet dFmt tFmt (utcToLocalTime tz <$> d)+++optionalLocalTimeFormlet :: Monad m+ => String+ -- ^ Date format string+ -> String+ -- ^ Time format string+ -> Maybe LocalTime+ -> Form Text m (Maybe LocalTime)+optionalLocalTimeFormlet dFmt tFmt d = liftM2 LocalTime+ <$> "date" .: optionalDateFormlet dFmt (localDay <$> d)+ <*> "time" .: optionalTimeFormlet tFmt (localTimeOfDay <$> d)+++optionalDateFormlet :: Monad m+ => String+ -- ^ Format string+ -> Maybe Day+ -> Form Text m (Maybe Day)+optionalDateFormlet fmt d =+ validate (vOpt $ vFunc fmt "invalid date") (string $ formatTime defaultTimeLocale fmt <$> d)+++optionalTimeFormlet :: Monad m+ => String+ -- ^ Format string+ -> Maybe TimeOfDay+ -> Form Text m (Maybe TimeOfDay)+optionalTimeFormlet fmt d =+ validate (vOpt $ vFunc fmt "invalid time") (string $ formatTime defaultTimeLocale fmt <$> d)+++vFunc :: ParseTime a => String -> Text -> String -> Result Text a+vFunc fmt err x+#if MIN_VERSION_time(1,5,0)+ | length x < 40 = maybe (Error err) Success $ parseTimeM True defaultTimeLocale fmt x+#else+ | length x < 40 = maybe (Error err) Success $ parseTime defaultTimeLocale fmt x+#endif+ | otherwise = Error "Not a valid date/time string"+++vOpt :: (String -> Result v a) -> String -> Result v (Maybe a)+vOpt _ "" = Success Nothing+vOpt f x = Just <$> f x++
+ src/Text/Digestive/Form/Encoding.hs view
@@ -0,0 +1,77 @@+--------------------------------------------------------------------------------+{-# LANGUAGE GADTs #-}+-- | Provides a datatype to differentiate between regular urlencoding and+-- multipart encoding for the content of forms and functions to determine+-- the content types of forms.+module Text.Digestive.Form.Encoding+ ( FormEncType (..)+ , formTreeEncType+ ) where+++--------------------------------------------------------------------------------+import Control.Monad.Identity (Identity)+import Data.Maybe (mapMaybe)+import Data.Monoid (Monoid (..), mconcat)+import Data.Semigroup (Semigroup (..))+++--------------------------------------------------------------------------------+import Text.Digestive.Form.Internal+import Text.Digestive.Form.Internal.Field+++--------------------------------------------------------------------------------+-- | Content type encoding of the form, either url encoded+-- (percent-encoding) or multipart encoding. For details, see:+-- <http://www.w3.org/TR/html401/interact/forms.html#h-17.13.4>+data FormEncType+ = UrlEncoded+ | MultiPart+ deriving (Eq)+++--------------------------------------------------------------------------------+instance Show FormEncType where+ show UrlEncoded = "application/x-www-form-urlencoded"+ show MultiPart = "multipart/form-data"+++--------------------------------------------------------------------------------+-- Semigroup instance for encoding types: prefer UrlEncoded, but fallback to+-- MultiPart when needed+instance Semigroup FormEncType where+ UrlEncoded <> x = x+ MultiPart <> _ = MultiPart+++--------------------------------------------------------------------------------+-- Monoid instance for encoding types: prefer UrlEncoded, but fallback to+-- MultiPart when needed+instance Monoid FormEncType where+ mempty = UrlEncoded+ mappend = (<>)+++--------------------------------------------------------------------------------+-- Only file uploads require the multipart encoding+fieldEncType :: Field v a -> FormEncType+fieldEncType File = MultiPart+fieldEncType _ = UrlEncoded+++--------------------------------------------------------------------------------+-- Retrieves all fields from a form tree+fieldList :: FormTree Identity 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+++--------------------------------------------------------------------------------+-- | Determines the encoding type of a "FormTree"+formTreeEncType :: FormTree Identity v m a -> FormEncType+formTreeEncType = mconcat . map fieldEncType' . fieldList+ where+ fieldEncType' (SomeField f) = fieldEncType f
+ src/Text/Digestive/Form/Internal.hs view
@@ -0,0 +1,421 @@+--------------------------------------------------------------------------------+-- | This module mostly meant for internal usage, and might change between minor+-- releases.+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+module Text.Digestive.Form.Internal+ ( Form+ , FormTree (..)+ , SomeForm (..)+ , Ref+ , Metadata (..)+ , transform+ , monadic+ , toFormTree+ , children+ , (.:)+ , getRef+ , lookupForm+ , lookupFormMetadata+ , lookupList+ , toField+ , queryField+ , eval+ , formMapView+ , forOptional++ -- * Debugging+ , debugFormPaths+ ) where+++--------------------------------------------------------------------------------+import Control.Applicative (Applicative (..))+import Control.Monad (liftM, liftM2, (>=>))+import Control.Monad.Identity (Identity (..))+import Data.Monoid (Monoid)+import Data.Traversable (mapM, sequenceA)+import Prelude hiding (mapM)+++--------------------------------------------------------------------------------+import Data.Text (Text)+import qualified Data.Text as T+++--------------------------------------------------------------------------------+import Text.Digestive.Form.Internal.Field+import Text.Digestive.Form.List+import Text.Digestive.Types+++--------------------------------------------------------------------------------+-- | 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.++type Form v m a = FormTree m v m a+++--------------------------------------------------------------------------------+-- | Embedded tree structure for forms - the basis for deferred evaluation+-- and the applicative interface.+data FormTree t v m a where+ -- Setting refs+ Ref :: Ref -> FormTree t v m a -> FormTree t v m a++ -- Applicative interface+ Pure :: Field v a -> FormTree t v m a+ App :: FormTree t v m (b -> a)+ -> FormTree t v m b+ -> FormTree t v m a++ -- Modifications+ Map :: (b -> m (Result v a)) -> FormTree t v m b -> FormTree t v m a+ Monadic :: t (FormTree t v m a) -> FormTree t v m a++ -- Dynamic lists+ List :: DefaultList (FormTree t v m a) -- Not the optimal structure+ -> FormTree t v m [Int]+ -> FormTree t v m [a]++ -- Add arbitrary metadata. This metadata applies to all children.+ Metadata :: [Metadata] -> FormTree t v m a -> FormTree t v m a+++--------------------------------------------------------------------------------+instance (Monad m, Monoid v) => Functor (FormTree t v m) where+ fmap = transform . (return .) . (return .)+++--------------------------------------------------------------------------------+instance (Monad m, Monoid v) => Applicative (FormTree t v m) where+ pure x = Pure (Singleton x)+ x <*> y = App x y+++--------------------------------------------------------------------------------+instance Show (FormTree Identity v m a) where+ show = unlines . showForm+++--------------------------------------------------------------------------------+-- | Value-agnostic Form+data SomeForm v m = forall a. SomeForm (FormTree Identity v m a)+++--------------------------------------------------------------------------------+instance Show (SomeForm v m) where+ show (SomeForm f) = show f+++--------------------------------------------------------------------------------+-- | Compact type for form labelling+type Ref = Text+++--------------------------------------------------------------------------------+data Metadata+ = Disabled+ deriving (Eq, Ord, Show)+++--------------------------------------------------------------------------------+-- Helper for the FormTree Show instance+showForm :: FormTree Identity v m a -> [String]+showForm form = case form of+ (Ref r x) -> ("Ref " ++ show r) : map indent (showForm x)+ (Pure x) -> ["Pure (" ++ show x ++ ")"]+ (App x y) -> concat+ [ ["App"]+ , map indent (showForm x)+ , map indent (showForm y)+ ]+ (Map _ x) -> "Map _" : map indent (showForm x)+ (Monadic x) -> "Monadic" : map indent (showForm $ runIdentity x)+ (List _ is) -> concat+ [ ["List <defaults>"] -- TODO show defaults+ , map indent (showForm is)+ ]+ (Metadata m x) -> ("Metadata " ++ show m) : map indent (showForm x)+ where+ indent = (" " ++)+++--------------------------------------------------------------------------------+-- | Map on the value type+transform :: (Monad m, Monoid v)+ => (a -> m (Result v b)) -> FormTree t v m a -> FormTree t v m b+transform f (Map g x) = Map (\y -> g y `bindResult` f) x+transform f x = Map f x+++--------------------------------------------------------------------------------+-- | Hide a monadic wrapper+monadic :: m (Form v m a) -> Form v m a+monadic = Monadic+++--------------------------------------------------------------------------------+-- | Normalize a Form to allow operations on the contents+toFormTree :: Monad m => Form v m a -> m (FormTree Identity v m a)+toFormTree (Ref r x) = liftM (Ref r) (toFormTree x)+toFormTree (Pure x) = return $ Pure x+toFormTree (App x y) = liftM2 App (toFormTree x) (toFormTree y)+toFormTree (Map f x) = liftM (Map f) (toFormTree x)+toFormTree (Monadic x) = x >>= toFormTree >>= return . Monadic . Identity+toFormTree (List d is) = liftM2 List (mapM toFormTree d) (toFormTree is)+toFormTree (Metadata m x) = liftM (Metadata m) (toFormTree x)+++--------------------------------------------------------------------------------+-- | Returns the topmost applicative or index trees if either exists+-- otherwise returns an empty list+children :: FormTree Identity v m a -> [SomeForm v m]+children (Ref _ x ) = children x+children (Pure _) = []+children (App x y) = [SomeForm x, SomeForm y]+children (Map _ x) = children x+children (Monadic x) = children $ runIdentity x+children (List _ is) = [SomeForm is]+children (Metadata _ x) = children x+++--------------------------------------------------------------------------------+pushRef :: Monad t => Ref -> FormTree t v m a -> FormTree t v m a+pushRef = Ref+++--------------------------------------------------------------------------------+-- | Operator to set a name for a subform.+(.:) :: Monad m => Text -> Form v m a -> Form v m a+(.:) = pushRef+infixr 5 .:+++--------------------------------------------------------------------------------+-- Return topmost label of the tree if it exists, with the rest of the form+popRef :: FormTree Identity v m a -> (Maybe Ref, FormTree Identity v m a)+popRef form = case form of+ (Ref r x) -> (Just r, x)+ (Pure _) -> (Nothing, form)+ (App _ _) -> (Nothing, form)+ (Map f x) -> let (r, form') = popRef x in (r, Map f form')+ (Monadic x) -> popRef $ runIdentity x+ (List _ _) -> (Nothing, form)+ (Metadata m x) -> let (r, form') = popRef x in (r, Metadata m form')+++--------------------------------------------------------------------------------+-- | Return the first/topmost label of a form+getRef :: FormTree Identity v m a -> Maybe Ref+getRef = fst . popRef+++--------------------------------------------------------------------------------+getMetadata :: FormTree Identity v m a -> [Metadata]+getMetadata (Ref _ _) = []+getMetadata (Pure _) = []+getMetadata (App _ _) = []+getMetadata (Map _ x) = getMetadata x+getMetadata (Monadic x) = getMetadata $ runIdentity x+getMetadata (List _ _) = []+getMetadata (Metadata m x) = m ++ getMetadata x+++--------------------------------------------------------------------------------+-- | Retrieve the form(s) at the given path+lookupForm :: Path -> FormTree Identity v m a -> [SomeForm v m]+lookupForm path = map fst . lookupFormMetadata path+++--------------------------------------------------------------------------------+-- | A variant of 'lookupForm' which also returns all metadata associated with+-- the form.+lookupFormMetadata :: Path -> FormTree Identity v m a+ -> [(SomeForm v m, [Metadata])]+lookupFormMetadata path = go [] path . SomeForm+ where+ -- Note how we use `popRef` to strip the ref away. This is really important.+ go md path' (SomeForm form) = case path' of+ [] -> [(SomeForm form, md')]+ (r : rs) -> case popRef form of+ (Just r', stripped)+ | r == r' && null rs -> [(SomeForm stripped, md')]+ | r == r' -> children form >>= go md' rs+ | otherwise -> []+ (Nothing, _) -> children form >>= go md' (r : rs)+ where+ md' = getMetadata form ++ md+++--------------------------------------------------------------------------------+-- | Always returns a List - fails if path does not directly reference a list+lookupList :: Path -> FormTree Identity v m a -> SomeForm v m+lookupList path form = case candidates of+ (SomeForm f : _) -> SomeForm f+ [] -> error $ "Text.Digestive.Form.Internal: " +++ T.unpack (fromPath path) ++ ": expected List, but got another form"+ where+ candidates =+ [ x+ | SomeForm f <- lookupForm path form+ , x <- getList f+ ]++ getList :: forall a v m. FormTree Identity v m a -> [SomeForm v m]+ getList (Ref _ _) = []+ getList (Pure _) = []+ getList (App x y) = getList x ++ getList y+ getList (Map _ x) = getList x+ getList (Monadic x) = getList $ runIdentity x+ getList (List d is) = [SomeForm (List d is)]+ getList (Metadata _ x) = getList x+++--------------------------------------------------------------------------------+-- | Returns the topmost untransformed single field, if one exists+toField :: FormTree Identity v m a -> Maybe (SomeField v)+toField (Ref _ x) = toField x+toField (Pure x) = Just (SomeField x)+toField (App _ _) = Nothing+toField (Map _ x) = toField x+toField (Monadic x) = toField (runIdentity x)+toField (List _ _) = Nothing+toField (Metadata _ x) = toField x+++--------------------------------------------------------------------------------+-- | Retrieve the field at the given path of the tree and apply the evaluation.+-- Used in field evaluation functions in "View".+queryField :: Path+ -> FormTree Identity 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+++--------------------------------------------------------------------------------+-- Annotate errors with the path from where they originated+ann :: Path -> Result v a -> Result [(Path, v)] a+ann _ (Success x) = Success x+ann path (Error x) = Error [(path, x)]+++--------------------------------------------------------------------------------+-- | Evaluate a formtree with a given method and environment.+-- Incrementally builds the path based on the set labels and+-- evaluates recursively - applying transformations and+-- applications with a bottom-up strategy.+eval :: Monad m => Method -> Env m -> FormTree Identity v m a+ -> m (Result [(Path, v)] a, [(Path, FormInput)])+eval = eval' []++eval' :: Monad m => Path -> Method -> Env m -> FormTree Identity v m a+ -> m (Result [(Path, v)] a, [(Path, FormInput)])++eval' path method env form = case form of+ Ref r x -> eval' (path ++ [r]) method env x++ Pure 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' path method env x+ x'' <- bindResult (return x') (f >=> return . ann path)+ return (x'', inp)++ Monadic x -> eval' path method env $ runIdentity x++ List defs fis -> do+ (ris, inp1) <- eval' path method env fis+ case ris of+ Error errs -> return (Error errs, inp1)+ Success is -> do+ res <- mapM+ -- TODO fix head defs+ (\i -> eval' (path ++ [T.pack $ show i])+ method env $ defs `defaultListIndex` i) is++ let (results, inps) = unzip res+ return (sequenceA results, inp1 ++ concat inps)++ Metadata _ x -> eval' path method env x+++--------------------------------------------------------------------------------+-- | Map on the error type of a FormTree -+-- used to define the Functor instance of "View.View"+formMapView :: Monad m+ => (v -> w) -> FormTree Identity v m a -> FormTree Identity w m a+formMapView f (Ref r x) = Ref r $ formMapView f x+formMapView f (Pure x) = Pure $ fieldMapView f x+formMapView f (App x y) = App (formMapView f x) (formMapView f y)+formMapView f (Map g x) = Map (g >=> return . resultMapError f) (formMapView f x)+formMapView f (Monadic x) = formMapView f $ runIdentity x+formMapView f (List d is) = List (fmap (formMapView f) d) (formMapView f is)+formMapView f (Metadata m x) = Metadata m $ formMapView f x+++--------------------------------------------------------------------------------+-- | Combinator that lifts input and output of valiation function used by 'validate'+-- to from (a -> Result v b) to (Maybe a -> Result v (Maybe b)).+forOptional :: (a -> Result v b) -> Maybe a -> Result v (Maybe b)+forOptional f x = case (x) of+ Nothing -> Success Nothing+ Just x' -> case (f x') of+ Success x'' -> Success (Just x'')+ Error x'' -> Error x''+++--------------------------------------------------------------------------------+-- | Utility: bind for 'Result' inside another monad+bindResult :: (Monad m, Monoid v)+ => 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'+++--------------------------------------------------------------------------------+-- | Debugging purposes+debugFormPaths :: (Monad m, Monoid v) => FormTree Identity v m a -> [Path]+debugFormPaths (Pure _) = [[]]+debugFormPaths (App x y) = debugFormPaths x ++ debugFormPaths y+debugFormPaths (Map _ x) = debugFormPaths x+debugFormPaths (Monadic x) = debugFormPaths $ runIdentity x+debugFormPaths (List d is) =+ debugFormPaths is +++ (map ("0" :) $ debugFormPaths $ d `defaultListIndex` 0)+debugFormPaths (Ref r x) = map (r :) $ debugFormPaths x+debugFormPaths (Metadata _ x) = debugFormPaths x
+ src/Text/Digestive/Form/Internal/Field.hs view
@@ -0,0 +1,107 @@+--------------------------------------------------------------------------------+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Internal embedding of form fields with associated functions.+module Text.Digestive.Form.Internal.Field+ ( Field (..)+ , SomeField (..)+ , evalField+ , fieldMapView+ ) where+++--------------------------------------------------------------------------------+import Control.Arrow (second)+import Data.Maybe (listToMaybe, mapMaybe, catMaybes)+import Data.Functor ((<$>))+import Data.List (findIndex)+import Data.Text (Text)+++--------------------------------------------------------------------------------+import Text.Digestive.Types+++--------------------------------------------------------------------------------+-- | 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+ -- A list of (group name, [(identifier, (value, view))]).+ -- Then we have the default index in the list.+ -- The return value has the actual value as well as the index in the list.+ Choice :: [(Text, [(Text, (a, v))])] -> [Int] -> Field v [(a, Int)]+ Bool :: Bool -> Field v Bool+ File :: Field v [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"+++--------------------------------------------------------------------------------+-- | Value agnostic "Field"+data SomeField v = forall a. SomeField (Field v a)+++--------------------------------------------------------------------------------+-- | Evaluate a field to retrieve a value, using the given method and+-- a list of input.+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 _ ts@(TextInput _ : _) (Choice ls _) =+ let ls' = concat (map snd ls) in+ catMaybes $+ map (\(TextInput x) ->+ (\i -> (fst $ snd $ ls' !! i, i)) <$> findIndex (isSelectedChoice x . fst) ls') ts+evalField Get _ (Choice ls x) =+ -- this populates the default values when displaying a view+ let ls' = concat (map snd ls) in+ map (\i -> (fst $ snd $ ls' !! i, i)) x+evalField Post _ (Choice _ _) = []+evalField Get _ (Bool x) = x+evalField Post (TextInput x : _) (Bool _) = x == "on"+evalField Post _ (Bool _) = False+evalField Post xs File = mapMaybe maybeFile xs+ where+ maybeFile (FileInput x) = Just x+ maybeFile _ = Nothing+evalField _ _ File = []+++--------------------------------------------------------------------------------+-- | Map on the error message type of a Field.+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 func) xs) i+ where func = map (second (second f))+fieldMapView _ (Bool x) = Bool x+fieldMapView _ File = File+++--------------------------------------------------------------------------------+-- | Determines if the choiceVal is equal to the selectedVal. Works with older+-- versions that submit "foo.bar.2" rather than "2" for Choice fields.+-- > isSelectedChoice "0" "0" == True+-- > isSelectedChoice "foo.bar.0" "0" == True+-- > isSelectedChoice "foo.bar.10" "0" == False+isSelectedChoice :: Text -> Text -> Bool+isSelectedChoice selectedVal choiceVal+ | selectedVal == choiceVal = True+ | otherwise =+ case listToMaybe (reverse $ toPath selectedVal) of+ Just x -> x == choiceVal+ _ -> False
+ src/Text/Digestive/Form/List.hs view
@@ -0,0 +1,75 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+-- | Functionality related to index storage and the DefaultList type.+module Text.Digestive.Form.List+ ( indicesRef+ , parseIndices+ , unparseIndices+ , DefaultList (..)+ , defaultListIndex+ ) where+++--------------------------------------------------------------------------------+import Control.Applicative ((<$>), (<*>))+import Data.Foldable (Foldable (..))+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Traversable (Traversable (..))+import Prelude hiding (foldr)+++--------------------------------------------------------------------------------+import Text.Digestive.Util+++--------------------------------------------------------------------------------+-- | Key used to store list indices+indicesRef :: Text+indicesRef = "indices"+++--------------------------------------------------------------------------------+-- | Parse a string of comma-delimited integers to a list.+-- Unparseable substrings are left out of the result.+parseIndices :: Text -> [Int]+parseIndices = mapMaybe (readMaybe . T.unpack) . T.split (== ',')+++--------------------------------------------------------------------------------+-- | Serialize a list of integers as a comma-delimited Text+unparseIndices :: [Int] -> Text+unparseIndices = T.intercalate "," . map (T.pack . show)+++--------------------------------------------------------------------------------+-- | A list which, when indexed on non-existant positions, returns a default+-- value.+data DefaultList a = DefaultList a [a]+++--------------------------------------------------------------------------------+instance Functor DefaultList where+ fmap f (DefaultList x xs) = DefaultList (f x) (map f xs)+++--------------------------------------------------------------------------------+instance Foldable DefaultList where+ foldr f z (DefaultList x xs) = f x (foldr f z xs)+++--------------------------------------------------------------------------------+instance Traversable DefaultList where+ traverse f (DefaultList x xs) = DefaultList <$> f x <*> traverse f xs+++--------------------------------------------------------------------------------+-- | Safe indexing of a DefaultList - returns the default value if+-- the given index is out of bounds.+defaultListIndex :: DefaultList a -> Int -> a+defaultListIndex (DefaultList x xs) i+ | i < 0 = x+ | otherwise = case drop i xs of+ (y : _) -> y+ [] -> x
− src/Text/Digestive/Forms.hs
@@ -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
− src/Text/Digestive/Forms/Html.hs
@@ -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
+ src/Text/Digestive/Ref.hs view
@@ -0,0 +1,31 @@+--------------------------------------------------------------------------------+-- | This module contains utilities for+-- creating text fragments to identify forms.+{-# LANGUAGE OverloadedStrings #-}+module Text.Digestive.Ref+ ( makeRef+ , makeRefs+ ) where+++--------------------------------------------------------------------------------+import qualified Data.ByteString as B+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Text.Printf (printf)+++--------------------------------------------------------------------------------+-- | Convert an arbitrary text value (possibly containing spaces, dots etc. to+-- a text value that can safely be used as an identifier in forms.+makeRef :: Text -> Text+makeRef =+ -- We simply UTF-8 encode and then hex encode, so all characters are valid.+ T.append "df-" . T.pack . (printf "%02x" =<<) . B.unpack . T.encodeUtf8+++--------------------------------------------------------------------------------+-- | Create an infinite list of refs.+makeRefs :: [Text]+makeRefs = map (T.pack . show) [0 :: Int ..]
− src/Text/Digestive/Result.hs
@@ -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)
− src/Text/Digestive/Transform.hs
@@ -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
src/Text/Digestive/Types.hs view
@@ -1,232 +1,100 @@--- | Core types----{-# LANGUAGE GeneralizedNewtypeDeriving #-}+--------------------------------------------------------------------------------+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Core types used internally 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+--------------------------------------------------------------------------------+import Control.Applicative (Applicative (..))+import Data.Monoid (Monoid, mappend) --- | 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+--------------------------------------------------------------------------------+import Data.Text (Text)+import qualified Data.Text as T --- | 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')+--------------------------------------------------------------------------------+-- | A mostly internally used type for representing Success/Error, with a+-- special applicative instance+data Result v a+ = Success a+ | Error v+ deriving (Show) --- | 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+--------------------------------------------------------------------------------+instance Functor (Result v) where+ fmap f (Success x) = Success (f x)+ fmap _ (Error x) = Error x --- | 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+--------------------------------------------------------------------------------+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) --- | 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+--------------------------------------------------------------------------------+instance Monoid v => Monad (Result v) where+ return x = Success x+ (Error x) >>= _ = Error x+ (Success x) >>= f = f x --- | 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))- }+--------------------------------------------------------------------------------+-- | 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 --- | 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)+--------------------------------------------------------------------------------+-- | Describes a path to a subform+type Path = [Text] -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) -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+--------------------------------------------------------------------------------+-- | Create a 'Path' from some text+toPath :: Text -> Path+toPath = filter (not . T.null) . T.split (== '.') -incState :: Monad m => FormState m i ()-incState = do- FormRange _ endF1 <- get- put $ unitRange endF1 --- | 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 ()))+--------------------------------------------------------------------------------+-- | Serialize a 'Path' to 'Text'+fromPath :: Path -> Text+fromPath = T.intercalate "." --- | 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 ++>+--------------------------------------------------------------------------------+-- | The HTTP methods+data Method = Get | Post+ deriving (Eq, Ord, Show) --- | 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 <+++--------------------------------------------------------------------------------+-- | The different input types sent by the browser+data FormInput+ = TextInput Text+ | FileInput FilePath+ deriving (Show) --- | 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, m (Result e a)) -- ^ Result-runForm form id' env = evalStateT (runReaderT (unForm form) env) $- unitRange $ zeroId id'---- | 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---- | 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)---- | 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]
+ src/Text/Digestive/Util.hs view
@@ -0,0 +1,15 @@+--------------------------------------------------------------------------------+-- | Utilities for safe failable parsing+module Text.Digestive.Util+ ( readMaybe+ ) where+++--------------------------------------------------------------------------------+import Data.Maybe (listToMaybe)+++--------------------------------------------------------------------------------+-- | 'read' in the 'Maybe' monad.+readMaybe :: Read a => String -> Maybe a+readMaybe str = listToMaybe [x | (x, "") <- readsPrec 1 str]
− src/Text/Digestive/Validate.hs
@@ -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']
+ src/Text/Digestive/View.hs view
@@ -0,0 +1,337 @@+--------------------------------------------------------------------------------+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | Provides functionality for frontend and backend integration.+--+-- This module contains functions used to glue form handling to+-- particular server implementations and view libraries, defining+-- the standard behaviour for handling GET and POST requests.+--+-- Field accessors can be used to write frontend libraries,+-- mapping field values to concrete elements.+module Text.Digestive.View+ ( View (..)++ -- * Obtaining a view+ , getForm+ , postForm++ -- * Operations on views+ , subView+ , subViews++ -- * Querying a view+ -- ** Low-level+ , absolutePath+ , absoluteRef++ -- ** Form encoding+ , viewEncType++ -- ** Input+ , fieldInputText+ , fieldInputChoice+ , fieldInputChoiceGroup+ , fieldInputBool+ , fieldInputFile++ -- ** List subview+ , listSubViews+ , makeListSubView++ -- ** Errors+ , errors+ , childErrors++ -- * Further metadata queries+ , viewDisabled++ -- * Debugging+ , debugViewPaths+ ) where+++--------------------------------------------------------------------------------+import Control.Arrow (second)+import Control.Monad.Identity (Identity)+import Data.List (isPrefixOf)+import Data.Monoid (Monoid)+import Data.Text (Text)+import qualified Data.Text as T+++--------------------------------------------------------------------------------+import Text.Digestive.Form.Encoding+import Text.Digestive.Form.Internal+import Text.Digestive.Form.Internal.Field+import Text.Digestive.Form.List+import Text.Digestive.Types+++--------------------------------------------------------------------------------+-- | Finalized form - handles the form, error messages and input.+-- Internally handles the addressing of individual fields.+data View v = forall a m. Monad m => View+ { viewName :: Text+ , viewContext :: Path+ , viewForm :: FormTree Identity 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+++--------------------------------------------------------------------------------+-- | Serve up a form for a GET request - no form input+getForm :: Monad m => Text -> Form v m a -> m (View v)+getForm name form = do+ form' <- toFormTree form+ return $ View name [] form' [] [] Get+++--------------------------------------------------------------------------------+-- | Handle a form for a POST request - evaluate with the given environment+-- and return the result.+postForm :: Monad m+ => Text -> Form v m a -> (FormEncType -> m (Env m))+ -> m (View v, Maybe a)+postForm name form makeEnv = do+ form' <- toFormTree form+ env <- makeEnv $ formTreeEncType form'+ let env' = env . (name :)+ 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)+++--------------------------------------------------------------------------------+-- | Returns the subview of a view matching the given serialized 'Path'+subView :: Text -> View v -> View v+subView ref (View name ctx form input errs method) =+ case lookupForm path form of+ [] ->+ View name (ctx ++ path) notFound (strip input) (strip errs) method+ (SomeForm f : _) ->+ View name (ctx ++ path) f (strip input) (strip errs) method+ where+ path = toPath ref+ lpath = length path++ strip :: [(Path, a)] -> [(Path, a)]+ strip xs = [(drop lpath p, x) | (p, x) <- xs, path `isPrefixOf` p]++ notFound :: FormTree Identity v Identity a+ notFound = error $ "Text.Digestive.View.subView: " +++ "No such subView: " ++ T.unpack ref+++--------------------------------------------------------------------------------+-- | Returns all immediate subviews of a view+subViews :: View v -> [View v]+subViews view@(View _ _ form _ _ _) =+ [subView r view | r <- go (SomeForm form)]+ where+ go (SomeForm f) = case getRef f of+ Nothing -> [r | c <- children f, r <- go c]+ Just r -> [r]+++--------------------------------------------------------------------------------+-- | Determine an absolute 'Path' for a field in the form+absolutePath :: Text -> View v -> Path+absolutePath ref (View name ctx _ _ _ _) = name : (ctx ++ toPath ref)+++--------------------------------------------------------------------------------+-- | Determine an absolute path and call 'fromPath' on it. Useful if you're+-- writing a view library...+absoluteRef :: Text -> View v -> Text+absoluteRef ref view = fromPath $ absolutePath ref view+++--------------------------------------------------------------------------------+-- | Returns the content type of the View - depends on contained fields+viewEncType :: View v -> FormEncType+viewEncType (View _ _ form _ _ _) = formTreeEncType form+++--------------------------------------------------------------------------------+-- Return form inputs which are paired with a path identical to the argument+lookupInput :: Path -> [(Path, FormInput)] -> [FormInput]+lookupInput path = map snd . filter ((== path) . fst)+++--------------------------------------------------------------------------------+-- | Return the text data at the position referred to by the given+-- serialized Path.+fieldInputText :: forall v. Text -> View v -> Text+fieldInputText ref (View _ _ form input _ method) =+ queryField path form eval'+ where+ path = toPath ref+ givenInput = lookupInput path input++ eval' :: Field v b -> Text+ eval' field = case field of+ Text t -> evalField method givenInput (Text t)+ f -> error $ T.unpack ref ++ ": expected (Text _), " +++ "but got: (" ++ show f ++ ")"+++--------------------------------------------------------------------------------+-- | Returns a list of (identifier, view, selected?)+fieldInputChoice :: forall v. Text -> View v -> [(Text, v, Bool)]+fieldInputChoice ref (View _ _ form input _ method) =+ queryField path form eval'+ where+ path = toPath ref+ givenInput = lookupInput path input++ eval' :: Field v b -> [(Text, v, Bool)]+ eval' field = case field of+ Choice xs didx ->+ let idx = map snd $ evalField method givenInput (Choice xs didx)+ in map (\(i, (k, (_, v))) -> (k, v, i `elem` idx)) $+ zip [0 ..] $ concat $ map snd xs+ f -> error $ T.unpack ref ++ ": expected (Choice _ _), " +++ "but got: (" ++ show f ++ ")"++--------------------------------------------------------------------------------+-- | Returns a list of (groupName, [(identifier, view, selected?)])+fieldInputChoiceGroup :: forall v. Text+ -> View v+ -> [(Text, [(Text, v, Bool)])]+fieldInputChoiceGroup ref (View _ _ form input _ method) =+ queryField path form eval'+ where+ path = toPath ref+ givenInput = lookupInput path input++ eval' :: Field v b -> [(Text, [(Text, v, Bool)])]+ eval' field = case field of+ Choice xs didx ->+ let idx = map snd $ evalField method givenInput (Choice xs didx)+ in merge idx xs [0..]+ f -> error $ T.unpack ref ++ ": expected (Choice _ _), " +++ "but got: (" ++ show f ++ ")"++merge :: [Int]+ -> [(Text, [(Text, (a, v))])]+ -> [Int]+ -> [(Text, [(Text, v, Bool)])]+merge _ [] _ = []+merge idx (g:gs) is = cur : merge idx gs b+ where+ (a,b) = splitAt (length $ snd g) is+ cur = (fst g, map (\(i, (k, (_, v))) -> (k, v, i `elem` idx)) $ zip a (snd g))++--------------------------------------------------------------------------------+-- | Returns True/False based on the field referred to by the given+-- serialized Path.+fieldInputBool :: forall v. Text -> View v -> Bool+fieldInputBool ref (View _ _ form input _ method) =+ queryField path form eval'+ where+ path = toPath ref+ givenInput = lookupInput path input++ eval' :: Field v b -> Bool+ eval' field = case field of+ Bool x -> evalField method givenInput (Bool x)+ f -> error $ T.unpack ref ++ ": expected (Bool _), " +++ "but got: (" ++ show f ++ ")"+++--------------------------------------------------------------------------------+-- | Return the FilePath referred to by the given serialized path, if set.+fieldInputFile :: forall v. Text -> View v -> [FilePath]+fieldInputFile ref (View _ _ form input _ method) =+ queryField path form eval'+ where+ path = toPath ref+ givenInput = lookupInput path input++ eval' :: Field v b -> [FilePath]+ eval' field = case field of+ File -> evalField method givenInput File+ f -> error $ T.unpack ref ++ ": expected (File), " +++ "but got: (" ++ show f ++ ")"+++--------------------------------------------------------------------------------+-- | Returns sub views referred to by dynamic list indices+-- at the given serialized path.+listSubViews :: Text -> View v -> [View v]+listSubViews ref view =+ map (\i -> makeListSubView ref i view) indices+ where+ path = toPath ref+ indicesPath = path ++ toPath indicesRef+ indices = parseIndices $ fieldInputText (fromPath indicesPath) view+++--------------------------------------------------------------------------------+-- | Creates a sub view+makeListSubView :: Text+ -- ^ ref+ -> Int+ -- ^ index to use for the subview+ -> View v+ -- ^ list view+ -> View v+makeListSubView ref ind view@(View _ _ form _ _ _) =+ case subView (fromPath $ path ++ [T.pack $ show ind]) view of+ View name ctx _ input errs method ->+ case lookupList path form of+ -- TODO don't use head+ (SomeForm (List defs _)) ->+ View name ctx (defs `defaultListIndex` ind)+ input errs method+ _ -> error $+ T.unpack ref ++ ": expected List, but got another form"+ where+ path = toPath ref+++--------------------------------------------------------------------------------+-- | Returns all errors related to the form corresponding to the given+-- serialized Path+errors :: Text -> View v -> [v]+errors ref = map snd . filter ((== toPath ref) . fst) . viewErrors+++--------------------------------------------------------------------------------+-- | Returns all errors related to the form, and its children, pointed+-- to by the given serialized Path.+childErrors :: Text -> View v -> [v]+childErrors ref = map snd .+ filter ((toPath ref `isPrefixOf`) . fst) . viewErrors+++--------------------------------------------------------------------------------+viewDisabled :: Text -> View v -> Bool+viewDisabled ref (View _ _ form _ _ _) = Disabled `elem` metadata+ where+ path = toPath ref+ metadata = concatMap snd $ lookupFormMetadata path form+++--------------------------------------------------------------------------------+-- | Retrieve all paths of the contained form+debugViewPaths :: Monoid v => View v -> [Path]+debugViewPaths (View _ _ form _ _ _) = debugFormPaths form
+ tests/TestSuite.hs view
@@ -0,0 +1,26 @@+module Main+ ( main+ ) where++import Test.Framework (defaultMain)++import qualified Text.Digestive.Field.Tests (tests)+import qualified Text.Digestive.Field.QTests (tests)+import qualified Text.Digestive.Form.Encoding.Tests (tests)+import qualified Text.Digestive.View.Tests (tests)+import qualified Text.Digestive.Form.QTests (tests)+import qualified Text.Digestive.Form.Encoding.QTests (tests)+import qualified Text.Digestive.Form.List.QTests (tests)++++main :: IO ()+main = defaultMain+ [ Text.Digestive.Field.Tests.tests+ , Text.Digestive.Field.QTests.tests+ , Text.Digestive.Form.Encoding.Tests.tests+ , Text.Digestive.View.Tests.tests+ , Text.Digestive.Form.QTests.tests+ , Text.Digestive.Form.Encoding.QTests.tests+ , Text.Digestive.Form.List.QTests.tests+ ]
+ tests/Text/Digestive/Field/QTests.hs view
@@ -0,0 +1,70 @@+--------------------------------------------------------------------------------+-- | Simple tests for applicative laws of the Result type+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Text.Digestive.Field.QTests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck hiding (Result, Success)+++--------------------------------------------------------------------------------+import Text.Digestive.Types+++--------------------------------------------------------------------------------+import Control.Applicative+import Control.Monad+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Text.Digestive.Field.QTests"+ [+ testProperty "Applicative identity for Result"+ prop_resappid+ ,testProperty "Applicative compositionality for Result"+ prop_resappcomp+ ]+++--------------------------------------------------------------------------------+instance (Arbitrary v, Arbitrary a) => Arbitrary (Result a v) where+ arbitrary = oneof [liftM Success arbitrary, liftM Error arbitrary]+++--------------------------------------------------------------------------------+-- Eq instance for convenience+instance (Eq a, Eq v) => Eq (Result a v)+ where (Success a) == (Success a') = a == a'+ (Error v) == (Error v') = v == v'+ _ == _ = False++--------------------------------------------------------------------------------+type ResFunc a = Result [Int] a+++--------------------------------------------------------------------------------+instance Show (Int -> Int)+ where show _ = ""+++--------------------------------------------------------------------------------+-- Identity (pure id <*> f == f)+prop_resappid :: Result [Int] Int -> Bool+prop_resappid f = (pure id <*> f) == f+++--------------------------------------------------------------------------------+-- Compositionality (pure (.) <*> u <*> v <*> w == u<*>(v<*>w))+prop_resappcomp :: ResFunc (Int -> Int) -> ResFunc (Int -> Int) ->+ Result [Int] (Int) -> Bool+prop_resappcomp u v w = (pure (.) <*> u <*> v <*> w) == (u <*> (v <*> w))+
+ tests/Text/Digestive/Field/Tests.hs view
@@ -0,0 +1,36 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Text.Digestive.Field.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?))+++--------------------------------------------------------------------------------+import Text.Digestive.Form.Internal.Field+import Text.Digestive.Types+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Text.Digestive.Field.Tests"+ [ testCase "evalField singleton" $+ 9160 @=? evalField undefined undefined (Singleton (9160 :: Int))++ , testCase "evalField bool post without input" $+ False @=? evalField Post [] (Bool True)++ , testCase "evalField bool post strange input" $+ False @=? evalField Post [TextInput "herp"] (Bool True)++ , testCase "evalField bool post correct input" $+ True @=? evalField Post [TextInput "on"] (Bool True)++ , testCase "evalField bool get" $+ True @=? evalField Get [] (Bool True)+ ]
+ tests/Text/Digestive/Form/Encoding/QTests.hs view
@@ -0,0 +1,49 @@+--------------------------------------------------------------------------------+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Text.Digestive.Form.Encoding.QTests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Data.Monoid+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+++--------------------------------------------------------------------------------+import Text.Digestive.Form.Encoding+++--------------------------------------------------------------------------------+-- Monoid properties+tests :: Test+tests = testGroup "Text.Digestive.Types.Tests"+ [+ testProperty "enctype monoid - Left identity" prop_idl+ , testProperty "enctype monoid - Right identity" prop_idr+ , testProperty "enctype monoid - Associativity" prop_assoc+ ]+++--------------------------------------------------------------------------------+prop_idl :: FormEncType -> Bool+prop_idl a = a `mappend` mempty == a+++--------------------------------------------------------------------------------+prop_idr :: FormEncType -> Bool+prop_idr a = mempty `mappend` a == a+++--------------------------------------------------------------------------------+prop_assoc :: FormEncType -> FormEncType -> FormEncType -> Bool+prop_assoc a b c = lhs == rhs+ where lhs = a `mappend` b `mappend` c+ rhs = a `mappend` (b `mappend` c)+++--------------------------------------------------------------------------------+instance Arbitrary FormEncType+ where arbitrary = elements [MultiPart, UrlEncoded]
+ tests/Text/Digestive/Form/Encoding/Tests.hs view
@@ -0,0 +1,35 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Text.Digestive.Form.Encoding.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Control.Applicative ((<$>), (<*>))+import Control.Monad.Identity (Identity (..))+import Data.Text (Text)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?))+++--------------------------------------------------------------------------------+import Text.Digestive.Form+import Text.Digestive.Form.Encoding+import Text.Digestive.Form.Internal+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Text.Digestive.Field.Tests"+ [ testCase "formEncType url-encoded" $+ UrlEncoded @=? formEncType' ((,) <$> text Nothing <*> bool Nothing)+ , testCase "formEncType multipart" $+ MultiPart @=? formEncType' ((,) <$> text Nothing <*> file)+ , testCase "formEncType multipart" $+ MultiPart @=? formEncType' ((,) <$> file <*> bool Nothing)+ ]+ where+ formEncType' :: Form Text Identity a -> FormEncType+ formEncType' = formTreeEncType . runIdentity . toFormTree
+ tests/Text/Digestive/Form/List/QTests.hs view
@@ -0,0 +1,25 @@+module Text.Digestive.Form.List.QTests+ ( tests+ ) where++--------------------------------------------------------------------------------+import Test.Framework+import Test.Framework.Providers.QuickCheck2+++--------------------------------------------------------------------------------+import Text.Digestive.Form.List+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Text.Digestive.Types.Tests"+ [+ testProperty "Parsing and serializing sanity check" prop_parseSym+ ]+++--------------------------------------------------------------------------------+-- Parsing serialized indices yields the same indices+prop_parseSym :: [Int] -> Bool+prop_parseSym is = (==is) . parseIndices . unparseIndices $ is
+ tests/Text/Digestive/Form/QTests.hs view
@@ -0,0 +1,108 @@+--------------------------------------------------------------------------------+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Text.Digestive.Form.QTests+ ( tests+ ) where++--------------------------------------------------------------------------------+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck hiding (Success)+++--------------------------------------------------------------------------------+import Text.Digestive.Form.Internal+import Text.Digestive.Form.Internal.Field+import Text.Digestive.Types+++--------------------------------------------------------------------------------+import Control.Monad+import Control.Monad.Identity+import Data.Maybe+import Data.Monoid (Monoid)+import Data.Text (Text, pack)+++--------------------------------------------------------------------------------++tests :: Test+tests = testGroup "Text.Digestive.Types.Tests"+ [+ testProperty "Mapping consistency" prop_viewcons+ , testProperty "Label consistency - map" prop_refcons+ , testProperty "Child count consistency - label" prop_pushcons+ , testProperty "Labelling consistency - monadic" prop_refmoncons+ ]++--------------------------------------------------------------------------------+-- Mapping on the view does not change the child count+prop_viewcons :: FormTree Identity String Identity Int -> Bool+prop_viewcons ft = (length . children $ ft) ==+ (length . children $ formMapView (length) ft)+++--------------------------------------------------------------------------------+-- Adding a label does not change the child count+prop_pushcons :: FormTree Identity String Identity Int -> Bool+prop_pushcons ft = lc ft == lc ("empty" .: ft)+ where lc = length . children+++--------------------------------------------------------------------------------+-- Sanity check - adding a ref and popping it yields the same Result+prop_refcons :: Text -> FormTree Identity String Identity Int -> Bool+prop_refcons ref ft = isJust ref' && fromJust ref' == ref+ where ref' = getRef (ref .: ft)+++--------------------------------------------------------------------------------+-- Sanity check - monadic wrap does not affect reference consistency+prop_refmoncons :: Text -> FormTree Identity String Identity Int -> Bool+prop_refmoncons ref ft = isJust ref' && fromJust ref' == ref+ where ref' = getRef (monadic . return $ (ref .: ft))+++--------------------------------------------------------------------------------+-- Limited arbitrary instance for form trees+instance (Monad t, Monad m, Monoid v, Arbitrary a) => Arbitrary (FormTree t v m a)+ where arbitrary = sized (innerarb $ liftM Pure arbitrary)+ where innerarb g 0 = g+ innerarb g n = innerarb g' (n-1)+ where g' = oneof+ [+ arbitrary >>= \r -> liftM (Ref r) g+ ,liftM (Monadic . return) g+ ,liftM (Map (return . Success . id)) g+ ,liftM2 App (liftM (fmap const) g) g+ ]++--------------------------------------------------------------------------------+-- Arbitrary SomeFields - encompasses all field types except for choice.+instance (Arbitrary v) => Arbitrary (SomeField v)+ where arbitrary =+ oneof [+ liftM (SomeField . Singleton) (arbitrary :: Gen Int)+ , liftM (SomeField . Text) arbitrary+ , liftM (SomeField . Bool) arbitrary+ , liftM SomeField $ elements [File]+ ]+++--------------------------------------------------------------------------------+-- Arbitrary Fields - limited to Singleton fields+instance (Arbitrary a) => Arbitrary (Field v a)+ where arbitrary = liftM Singleton (arbitrary)+++--------------------------------------------------------------------------------+-- Arbitrary Text - should be factored out+instance Arbitrary Text+ where arbitrary = liftM pack arbitrary++--------------------------------------------------------------------------------+-- Show instance - should probably be moved to Field.hs+instance (Show v) => Show (SomeField v)+ where show (SomeField f) = show f
+ tests/Text/Digestive/Tests/Fixtures.hs view
@@ -0,0 +1,262 @@+--------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+module Text.Digestive.Tests.Fixtures+ ( -- * Pokemon!+ TrainerM+ , runTrainerM+ , Type (..)+ , Pokemon (..)+ , pokemonForm+ , ValidateOptionalData (..)+ , validateOptionalForm+ , IndependentValidationsData (..)+ , independentValidationsForm+ , Ball (..)+ , ballForm+ , Catch (..)+ , catchForm++ -- * Store/product+ , Database+ , runDatabase+ , sector9+ , earthwing+ , comet+ , Product (..)+ , productForm+ , Order (..)+ , orderForm+ , ordersForm++ -- * Various+ , floatForm+ ) where+++--------------------------------------------------------------------------------+import Control.Applicative ((<$>), (<*>))+import Control.Monad ((>=>))+import Control.Monad.Reader (Reader, ask, runReader)+import Data.Text (Text)+import qualified Data.Text as T+++--------------------------------------------------------------------------------+import Text.Digestive.Form+import Text.Digestive.Types+import Text.Digestive.Util+++--------------------------------------------------------------------------------+-- Maximum level+type TrainerM = Reader Int+++--------------------------------------------------------------------------------+-- Default max level: 20+runTrainerM :: TrainerM a -> a+runTrainerM = flip runReader 20+++--------------------------------------------------------------------------------+data Type = Water | Fire | Leaf | Rock+ deriving (Eq, Show)+++--------------------------------------------------------------------------------+typeChoices :: [(Type, Text)]+typeChoices = [(Water, "Water"), (Fire, "Fire"), (Leaf, "Leaf"), (Rock, "Rock")]+++--------------------------------------------------------------------------------+typeForm :: Monad m => Form Text m Type+typeForm = choice typeChoices Nothing+++--------------------------------------------------------------------------------+weaknessForm :: Monad m => Form Text m [Type]+weaknessForm = choiceMultiple typeChoices Nothing+++--------------------------------------------------------------------------------+data Pokemon = Pokemon+ { pokemonName :: Text+ , pokemonLevel :: Maybe Int+ , pokemonType :: Type+ , pokemonWeakness :: [Type]+ , pokemonRare :: Bool+ } deriving (Eq, Show)+++--------------------------------------------------------------------------------+levelForm :: Form Text TrainerM (Maybe Int)+levelForm =+ checkM "This pokemon will not obey you!" checkMaxLevel $+ check "Level should be at least 1" (maybe True (> 1)) $+ optionalStringRead "Cannot parse level" Nothing+ where+ checkMaxLevel Nothing = return True+ checkMaxLevel (Just l) = do+ maxLevel <- ask+ return $ l <= maxLevel+++--------------------------------------------------------------------------------+pokemonForm :: Form Text TrainerM Pokemon+pokemonForm = Pokemon+ <$> "name" .: validate isPokemon (text Nothing)+ <*> "level" .: levelForm+ <*> "type" .: typeForm+ <*> "weakness" .: weaknessForm+ <*> "rare" .: bool Nothing+ where+ definitelyNoPokemon = ["dog", "cat"]+ isPokemon name+ | name `notElem` definitelyNoPokemon = Success name+ | otherwise =+ Error $ name `T.append` " is not a pokemon!"+++--------------------------------------------------------------------------------+data Ball = Poke | Great | Ultra | Master+ deriving (Eq, Show)+++--------------------------------------------------------------------------------+ballForm :: Monad m => Form Text m Ball+ballForm = choice+ [(Poke, "Poke"), (Great, "Great"), (Ultra, "Ultra"), (Master, "Master")]+ Nothing+++--------------------------------------------------------------------------------+data ValidateOptionalData = ValidateOptionalData+ { firstValidateOptionalField :: Maybe Integer+ } deriving (Eq, Show)+++--------------------------------------------------------------------------------+validateOptionalForm :: Monad m => Form Text m ValidateOptionalData+validateOptionalForm = ValidateOptionalData+ <$> "first_field" .: validateOptional (integer >=> even' >=> greaterThan 0) (optionalString Nothing)+ where+ integer s = maybe (Error "not an integer") Success (readMaybe s)+ even' n+ | n `mod` 2 == 0 = Success n+ | otherwise = Error "input must be even"+ greaterThan x n+ | n > x = Success n+ | otherwise = Error "input is too small"+++--------------------------------------------------------------------------------+data IndependentValidationsData = IndependentValidationsData+ { firstIndependentValidationField :: Integer+ } deriving (Eq, Show)+++--------------------------------------------------------------------------------+independentValidationsForm :: Monad m => Form [Text] m IndependentValidationsData+independentValidationsForm = IndependentValidationsData+ <$> "first_field" .: validate (notEmpty >=> integer >=> conditions [even', greaterThan 10]) (string Nothing)+ where+ notEmpty x = if (null x)+ then Error ["is empty"]+ else Success x+ integer s = maybe (Error ["not an integer"]) Success (readMaybe s)+ even' n+ | n `mod` 2 == 0 = Success n+ | otherwise = Error "input must be even"+ greaterThan x n+ | n > x = Success n+ | otherwise = Error "input is too small"+++--------------------------------------------------------------------------------+data Catch = Catch+ { catchPokemon :: Pokemon+ , catchBall :: Ball+ } deriving (Eq, Show)+++--------------------------------------------------------------------------------+catchForm :: Form Text TrainerM Catch+catchForm = check "You need a better ball" canCatch $ Catch+ <$> "pokemon" .: pokemonForm+ <*> "ball" .: ballForm+++--------------------------------------------------------------------------------+canCatch :: Catch -> Bool+canCatch (Catch (Pokemon _ _ _ _ False) _) = True+canCatch (Catch (Pokemon _ _ _ _ True) Ultra) = True+canCatch (Catch (Pokemon _ _ _ _ True) Master) = True+canCatch _ = False+++--------------------------------------------------------------------------------+type Database = Reader [Product]+++--------------------------------------------------------------------------------+runDatabase :: Database a -> a+runDatabase = flip runReader [sector9, earthwing, comet]+++--------------------------------------------------------------------------------+sector9 :: Product+sector9 = Product "s9_ao" "Sector 9 Agent Orange"+++--------------------------------------------------------------------------------+earthwing :: Product+earthwing = Product "ew_br" "Earthwing Belly Racer"+++--------------------------------------------------------------------------------+comet :: Product+comet = Product "cm_gs" "Comet Grease Shark"+++--------------------------------------------------------------------------------+data Product = Product+ { productId :: Text+ , productName :: Text+ } deriving (Eq, Show)+++--------------------------------------------------------------------------------+productForm :: Formlet Text Database Product+productForm def = monadic $ do+ products <- ask+ return $ choiceWith (map makeChoice products) def+ where+ makeChoice p = (productId p, (p, productName p))+++--------------------------------------------------------------------------------+data Order = Order+ { orderProduct :: Product+ , orderQuantity :: Int+ } deriving (Eq, Show)+++--------------------------------------------------------------------------------+orderForm :: Formlet Text Database Order+orderForm def = Order+ <$> "product" .: productForm (orderProduct <$> def)+ <*> "quantity" .: stringRead "Can't parse" (orderQuantity <$> def)+++--------------------------------------------------------------------------------+ordersForm :: Formlet Text Database (Text, [Order])+ordersForm def = (,)+ -- This field is disabled.+ <$> disable ("name" .: text (fst <$> def))+ -- id is here because of a regression+ <*> (id <$> "orders" .: listOf orderForm (snd <$> def))+++--------------------------------------------------------------------------------+floatForm :: Monad m => Form Text m Float+floatForm = "f" .: stringRead "Can't parse float" Nothing
+ tests/Text/Digestive/Types/QTests.hs view
@@ -0,0 +1,48 @@+module Text.Digestive.Types.QTests+ ( tests+ ) where++--------------------------------------------------------------------------------+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+++--------------------------------------------------------------------------------+import Text.Digestive.Types+++--------------------------------------------------------------------------------+import Data.Text+import Control.Monad+++--------------------------------------------------------------------------------++tests :: Test+tests = testGroup "Text.Digestive.Types.Tests"+ [+ testProperty "Path parsing and serializing" prop_parseSym+ ]++--------------------------------------------------------------------------------+-- This property does not hold in the current implementation,+-- ".a.b...c." will yield the same path as "a.b.c"+prop_parseSym :: PText -> Bool+prop_parseSym pt = (==p) . fromPath . toPath $ p+ where p = runPT pt+++--------------------------------------------------------------------------------+newtype PText = PT {runPT :: Text}+ deriving Show+++--------------------------------------------------------------------------------+instance Arbitrary PText+ where arbitrary = liftM PT arbitrary+++--------------------------------------------------------------------------------+instance Arbitrary Text+ where arbitrary = liftM pack arbitrary
+ tests/Text/Digestive/View/Tests.hs view
@@ -0,0 +1,208 @@+-------------------------------------------------------------------------------+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Text.Digestive.View.Tests+ ( tests+ ) where+++--------------------------------------------------------------------------------+import Control.Exception (SomeException, handle)+import Control.Monad.Identity (runIdentity)+import Data.Text (Text)+import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit ((@=?), (@?=))+import qualified Test.HUnit as H+++--------------------------------------------------------------------------------+import Text.Digestive.Form.Encoding+import Text.Digestive.Tests.Fixtures+import Text.Digestive.Types+import Text.Digestive.View+++--------------------------------------------------------------------------------+assertError :: Show a => a -> H.Assertion+assertError x = handle (\(_ :: SomeException) -> H.assert True) $+ x `seq` H.assertFailure $ "Should throw an error but gave: " ++ show x+++--------------------------------------------------------------------------------+tests :: Test+tests = testGroup "Text.Digestive.View.Tests"+ [ testCase "Simple postForm" $ (@=?)+ (Just (Pokemon "charmander" (Just 5) Fire [Water, Rock] False)) $+ snd $ runTrainerM $ postForm "f" pokemonForm $ testEnv+ [ ("f.name", "charmander")+ , ("f.level", "5")+ , ("f.type", "type.1")+ , ("f.weakness", "0") -- NOTE: this is the newer style of Choice values+ , ("f.weakness", "3")+ ]++ , testCase "optional unspecified" $ (@=?)+ (Just (Pokemon "magmar" Nothing Fire [Water, Rock] False)) $+ snd $ runTrainerM $ postForm "f" pokemonForm $ testEnv+ [ ("f.name", "magmar")+ , ("f.type", "type.1")+ , ("f.weakness", "weakness.0") -- NOTE: this is the older style of Choice values+ , ("f.weakness", "weakness.3")+ ]++ , testCase "stringRead float" $ (@=?)+ (Just 4.323 :: Maybe Float) $+ snd $ runIdentity $ postForm "f" floatForm $ testEnv+ [("f.f", "4.323")]++ , testCase "validateOptional validated successfully" $ (@=?)+ (Just (ValidateOptionalData (Just 8))) $+ snd $ runIdentity $ postForm "f" validateOptionalForm $ testEnv+ [("f.first_field", "8")]++ , testCase "validateOptional allows nothing" $ (@=?)+ (Just (ValidateOptionalData Nothing)) $+ snd $ runIdentity $ postForm "f" validateOptionalForm $ testEnv+ [("f.first_field", "")]++ , testCase "validateOptional fails for invalid data" $ (@=?)+ ["input must be even"] $+ childErrors "" $ fst $ runIdentity $ postForm "f" validateOptionalForm $ testEnv+ [("f.first_field", "9")]++ , testCase "conditions allows for multiple independent failing validations" $ (@=?)+ [["input must be even", "input is too small"]] $+ childErrors "" $ fst $ runIdentity $ postForm "f" independentValidationsForm $ testEnv+ [("f.first_field", "9")]++ , testCase "Failing checkM" $ (@=?)+ ["This pokemon will not obey you!"] $+ childErrors "" $ fst $ runTrainerM $ postForm "f" pokemonForm $ testEnv+ [ ("f.name", "charmander")+ , ("f.level", "9000")+ , ("f.type", "type.1")+ ]++ , testCase "Failing validate" $ (@=?)+ ["dog is not a pokemon!"] $+ childErrors "" $ fst $ runTrainerM $ postForm "f" pokemonForm $ testEnv+ [("f.name", "dog")]++ , testCase "Simple fieldInputChoice" $ (@=?)+ "Leaf" $+ snd $ selection $ fieldInputChoice "type" $ fst $ runTrainerM $+ postForm "f" pokemonForm $ testEnv [("f.type", "type.2")]++ , testCase "Nested postForm" $ (@=?)+ (Just (Catch (Pokemon "charmander" (Just 5) Fire [Water, Rock] False) Ultra)) $+ snd $ runTrainerM $ postForm "f" catchForm $ testEnv+ [ ("f.pokemon.name", "charmander")+ , ("f.pokemon.level", "5")+ , ("f.pokemon.type", "type.1")+ , ("f.pokemon.weakness", "weakness.0")+ , ("f.pokemon.weakness", "weakness.3")+ , ("f.ball", "ball.2")+ ]++ , testCase "subView errors" $ (@=?)+ ["Cannot parse level"] $+ errors "level" $ subView "pokemon" $ fst $ runTrainerM $+ postForm "f" catchForm $ testEnv [("f.pokemon.level", "hah.")]++ , testCase "subView childErrors" $ (@=?)+ ["Cannot parse level"] $+ childErrors "" $ subView "pokemon" $ fst $ runTrainerM $+ postForm "f" catchForm $ testEnv [("f.pokemon.level", "hah.")]++ , testCase "subView input" $ (@=?)+ "Leaf" $+ snd $ selection $ fieldInputChoice "type" $ subView "pokemon" $ fst $+ runTrainerM $ postForm "f" catchForm $ testEnv+ [ ("f.pokemon.level", "hah.")+ , ("f.pokemon.type", "type.2")+ ]++ , testCase "subViews length" $ (@=?)+ 5 $+ length $ subViews $ runTrainerM $ getForm "f" pokemonForm++ , testCase "subViews after subView length" $ (@=?)+ 5 $+ length $ subViews $ subView "pokemon" $+ runTrainerM $ getForm "f" catchForm++ , testCase "Abusing Choice as Text" $ assertError $+ fieldInputText "type" $ runTrainerM $ getForm "f" pokemonForm++ , testCase "Abusing Bool as Choice" $ assertError $+ fieldInputChoice "rare" $ runTrainerM $ getForm "f" pokemonForm++ , testCase "Abusing Text as Bool" $ assertError $+ fieldInputBool "name" $ runTrainerM $ getForm "f" pokemonForm++ , testCase "monadic choiceWith" $ (@=?)+ (Just (Order comet 2)) $+ snd $ runDatabase $ postForm "f" (orderForm Nothing) $ testEnv+ -- We actually need f.product.cm_gs for the choice input, but this+ -- must work as well!+ [ ("f.product", "cm_gs")+ , ("f.quantity", "2")+ ]++ , testCase "monadic view query" $ (@=?)+ "Earthwing Belly Racer" $+ snd $ selection $ fieldInputChoice "product" $ runDatabase $+ getForm "f"+ -- With a default+ (orderForm $ Just $ Order earthwing 10)++ , -- Let me just order 3 awesome skateboards here+ testCase "Simple listOf" $ do+ let (view, result) = runDatabase $ postForm "f" (ordersForm Nothing) $+ testEnv+ [ ("f.name", "Jasper")+ {- \ /\ -} , ("f.orders.indices", "0,10")+ {- ) ( ') -} , ("f.orders.0.product", "cm_gs")+ {- ( / ) -} , ("f.orders.0.quantity", "2")+ {- \(__)| -} , ("f.orders.10.product", "s9_ao")+ , ("f.orders.10.quantity", "1")+ ]++ result @?= Just+ ( "Jasper"+ , [ Order (Product "cm_gs" "Comet Grease Shark") 2+ , Order (Product "s9_ao" "Sector 9 Agent Orange") 1+ ]+ )++ let subViews' = listSubViews "orders" view+ fieldInputText "quantity" (head subViews') @?= "2"++ , testCase "listOf with defaults" $ do+ let view = runDatabase $ getForm "f" $ ordersForm $ Just+ ( "Jasper"+ , [ Order comet 2+ , Order sector9 3+ ]+ )++ let subViews' = listSubViews "orders" view+ fst (selection (fieldInputChoice "product" (subViews' !! 1))) @=?+ "s9_ao"++ , testCase "Simple viewDisabled" $ do+ let view = runDatabase $ getForm "f" (ordersForm Nothing)+ True @=? viewDisabled "name" view+ ]+++--------------------------------------------------------------------------------+testEnv :: Monad m => [(Text, Text)] -> FormEncType -> m (Env m)+testEnv input _formEncType = return $ \key -> return $ map (TextInput . snd) $+ filter ((== fromPath key) . fst) input+++--------------------------------------------------------------------------------+selection :: [(Text, v, Bool)] -> (Text, v)+selection fic = head [(t, v) | (t, v, s) <- fic, s]