digestive-functors 0.6.0.1 → 0.6.1.0

raw patch · 19 files changed

+583/−88 lines, 19 filesdep +QuickCheckdep +test-framework-quickcheck2dep ~test-framework-hunitPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, test-framework-quickcheck2

Dependency ranges changed: test-framework-hunit

API changes (from Hackage documentation)

Files

• digestive-functors.cabal +13/−5
• src/Text/Digestive.hs +8/−0
• src/Text/Digestive/Form.hs +31/−3
• src/Text/Digestive/Form/Encoding.hs +11/−0
• src/Text/Digestive/Form/Internal.hs +136/−67
• src/Text/Digestive/Form/Internal/Field.hs +7/−0
• src/Text/Digestive/Form/List.hs +7/−0
• src/Text/Digestive/Ref.hs +3/−3
• src/Text/Digestive/Types.hs +1/−0
• src/Text/Digestive/Util.hs +1/−0
• src/Text/Digestive/View.hs +48/−9
• tests/TestSuite.hs +10/−0
• tests/Text/Digestive/Field/QTests.hs +70/−0
• tests/Text/Digestive/Form/Encoding/QTests.hs +50/−0
• tests/Text/Digestive/Form/List/QTests.hs +25/−0
• tests/Text/Digestive/Form/QTests.hs +106/−0
• tests/Text/Digestive/Tests/Fixtures.hs +4/−1
• tests/Text/Digestive/Types/QTests.hs +48/−0
• tests/Text/Digestive/View/Tests.hs +4/−0

@@ -1,5 +1,5 @@ Name:     digestive-functors-Version:  0.6.0.1+Version:  0.6.1.0 Synopsis: A practical formlet library  Description:@@ -68,17 +68,25 @@   Type:           exitcode-stdio-1.0   Hs-source-dirs: src tests   Main-is:        TestSuite.hs+  Ghc-options:    -Wall+   Other-modules:       Text.Digestive.Field.Tests+      Text.Digestive.Field.QTests       Text.Digestive.Form.Encoding.Tests+      Text.Digestive.Form.Encoding.QTests+      Text.Digestive.Form.List.QTests+      Text.Digestive.Form.QTests       Text.Digestive.Tests.Fixtures       Text.Digestive.View.Tests-  Ghc-options:    -Wall+      Text.Digestive.Types.QTests    Build-depends:-    HUnit                >= 1.2 && < 1.3,-    test-framework       >= 0.4 && < 0.9,-    test-framework-hunit >= 0.2 && < 0.4,+    HUnit                      >= 1.2 && < 1.3,+    QuickCheck                 >= 2.5 && < 2.6,+    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,

@@ -3,10 +3,15 @@ -- <http://github.com/jaspervdj/digestive-functors/blob/master/examples/tutorial.lhs> module Text.Digestive     ( 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+-- | Core non-internal types     , module Text.Digestive.View+-- | Functionality for front-end interfacing     ) where  @@ -16,3 +21,6 @@ import           Text.Digestive.Ref import           Text.Digestive.Types import           Text.Digestive.View+++

@@ -3,6 +3,9 @@ {-# 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@@ -29,11 +32,12 @@     , optionalString     , optionalStringRead -      -- * Validation+      -- * Validation and transformation     , check     , checkM     , validate     , validateM+    , disable        -- * Lifting forms     , monadic@@ -61,25 +65,31 @@   --------------------------------------------------------------------------------+-- | 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 :: Formlet v m Text text def = Pure $ Text $ fromMaybe "" def   --------------------------------------------------------------------------------+-- | Identical to "text" but takes a String string :: Monad m => 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, 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+-- the provided list of value-message tuples choice :: (Eq a, Monad m) => [(a, v)] -> Formlet v m a choice items def = choiceWith (zip makeRefs items) def @@ -103,7 +113,7 @@   ----------------------------------------------------------------------------------- | A version of 'choiceWith' for when you have no good 'Eq' instance.+-- | A version of 'choiceWith' for when there is no good 'Eq' instance. choiceWith' :: Monad m => [(Text, (a, v))] -> Maybe Int -> Form v m a choiceWith' items def = fmap fst $ Pure $ Choice [("", items)] def'   where@@ -111,6 +121,7 @@   --------------------------------------------------------------------------------+-- | Returns a 'Formlet' for named groups of choices. groupedChoice :: (Eq a, Monad m) => [(Text, [(a, v)])] -> Formlet v m a groupedChoice items def =     groupedChoiceWith (mkGroupedRefs items makeRefs) def@@ -160,11 +171,13 @@   --------------------------------------------------------------------------------+-- | Returns a 'Formlet' for binary choices bool :: Formlet v m Bool bool = Pure . Bool . fromMaybe False   --------------------------------------------------------------------------------+-- | Returns a 'Formlet' for file selection file :: Form v m (Maybe FilePath) file = Pure File @@ -205,7 +218,6 @@ -- > -- > char :: Monad m => Form m String Char -- > char = validate head' (string Nothing)--- validate :: Monad m => (a -> Result v b) -> Form v m a -> Form v m b validate = validateM . (return .) @@ -217,6 +229,15 @@   --------------------------------------------------------------------------------+-- | 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 => Maybe Text -> Form v m (Maybe Text) optionalText def = validate optional (text def)   where@@ -226,11 +247,13 @@   --------------------------------------------------------------------------------+-- | Identical to 'optionalText', but uses Strings optionalString :: Monad m => 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, Read a, Show a)                    => v -> Maybe a -> Form v m (Maybe a) optionalStringRead err = transform readTransform' . optionalString . fmap show@@ -240,11 +263,13 @@   --------------------------------------------------------------------------------+-- Helper function for attempted parsing, with custom error messages readTransform :: (Monad m, Read a) => v -> String -> m (Result v a) readTransform err = return . maybe (Error err) return . readMaybe   --------------------------------------------------------------------------------+-- | Dynamic lists listOf :: Monad m        => Formlet v m a        -> Formlet v m [a]@@ -259,5 +284,8 @@   --------------------------------------------------------------------------------+-- Manipulatable indices listIndices :: Monad m => [Int] -> Form v m [Int] listIndices = fmap parseIndices . text . Just . unparseIndices++

@@ -1,5 +1,8 @@ -------------------------------------------------------------------------------- {-# 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 (..)     , formEncType@@ -20,6 +23,9 @@   --------------------------------------------------------------------------------+-- | 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@@ -42,12 +48,14 @@   --------------------------------------------------------------------------------+-- 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@@ -56,11 +64,14 @@   --------------------------------------------------------------------------------+-- | Determines the encoding type of a "Form" -+-- returns result in evaluating context formEncType :: Monad m => Form v m a -> m FormEncType formEncType form = liftM formTreeEncType $ toFormTree form   --------------------------------------------------------------------------------+-- | Determines the encoding type of a "FormTree" formTreeEncType :: FormTree Identity v m a -> FormEncType formTreeEncType = mconcat . map fieldEncType' . fieldList   where

@@ -11,6 +11,7 @@     , FormTree (..)     , SomeForm (..)     , Ref+    , Metadata (..)     , transform     , monadic     , toFormTree@@ -18,6 +19,7 @@     , (.:)     , getRef     , lookupForm+    , lookupFormMetadata     , lookupList     , toField     , queryField@@ -31,8 +33,7 @@  -------------------------------------------------------------------------------- import           Control.Applicative                (Applicative (..))-import           Control.Monad                      (liftM, liftM2,-                                                     mapAndUnzipM, (>=>))+import           Control.Monad                      (liftM, liftM2, (>=>)) import           Control.Monad.Identity             (Identity (..)) import           Data.Monoid                        (Monoid) import           Data.Traversable                   (mapM, sequenceA)@@ -64,31 +65,36 @@ -- -- * @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+    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+    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+    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]+    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 => Functor (FormTree t v m) where     fmap = transform . (return .) . (return .)@@ -106,6 +112,7 @@   --------------------------------------------------------------------------------+-- | Value-agnostic Form data SomeForm v m = forall a. SomeForm (FormTree Identity v m a)  @@ -115,10 +122,18 @@   --------------------------------------------------------------------------------+-- | 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)@@ -134,40 +149,48 @@         [ ["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           => (a -> m (Result v b)) -> FormTree t v m a -> FormTree t v m b-transform f (Map g x) = flip Map x $ \y -> bindResult (g y) f+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 (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 (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   --------------------------------------------------------------------------------@@ -183,37 +206,63 @@   --------------------------------------------------------------------------------+-- 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)+    (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 = go path . SomeForm+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 []       form            = [form]-    go (r : rs) (SomeForm form) = case popRef form of-        (Just r', stripped)-            | r == r' && null rs -> [SomeForm stripped]-            | r == r'            -> children form >>= go rs-            | otherwise          -> []-        (Nothing, _)             -> children form >>= go (r : rs)+    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+-- | 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@@ -227,25 +276,30 @@         ]      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 (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 (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)@@ -260,12 +314,17 @@   --------------------------------------------------------------------------------+-- 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' []@@ -298,28 +357,37 @@         case ris of             Error errs -> return (Error errs, inp1)             Success is -> do-                (results, inps) <- mapAndUnzipM+                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 (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   -------------------------------------------------------------------------------- -- | Utility: bind for 'Result' inside another monad bindResult :: Monad m-           => m (Result v a) -> (a -> m (Result v b)) -> m (Result v b)+           => m (Result v a) ->+           (a -> m (Result v b)) ->+           m (Result v b) bindResult mx f = do     x <- mx     case x of@@ -330,11 +398,12 @@ -------------------------------------------------------------------------------- -- | Debugging purposes debugFormPaths :: Monad m => 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 (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 (Ref r x)      = map (r :) $ debugFormPaths x+debugFormPaths (Metadata _ x) = debugFormPaths x

@@ -3,6 +3,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs                     #-} {-# LANGUAGE OverloadedStrings         #-}+-- | Internal embedding of form fields with associated functions. module Text.Digestive.Form.Internal.Field     ( Field (..)     , SomeField (..)@@ -44,10 +45,13 @@   --------------------------------------------------------------------------------+-- | 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@@ -74,6 +78,7 @@   --------------------------------------------------------------------------------+-- | 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@@ -84,6 +89,8 @@   --------------------------------------------------------------------------------+-- | Retrieve the value and position of the value referenced to by the given+-- key in an association list, if the key is in the list. lookupIdx :: Eq k => k -> [(k, v)] -> Maybe (v, Int) lookupIdx key = go 0   where

@@ -1,5 +1,6 @@ -------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-}+-- | Functionality related to index storage and the DefaultList type. module Text.Digestive.Form.List     ( indicesRef     , parseIndices@@ -24,16 +25,20 @@   --------------------------------------------------------------------------------+-- | 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) @@ -60,6 +65,8 @@   --------------------------------------------------------------------------------+-- | 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

@@ -1,6 +1,6 @@ ----------------------------------------------------------------------------------- | This module contains utilities for creating text fragments to identify--- forms.+-- | This module contains utilities for+-- creating text fragments to identify forms. {-# LANGUAGE OverloadedStrings #-} module Text.Digestive.Ref     ( makeRef@@ -18,7 +18,7 @@  -------------------------------------------------------------------------------- -- | Convert an arbitrary text value (possibly containing spaces, dots etc. to--- a text value that safely be used as an identifier in forms.+-- 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.

@@ -1,5 +1,6 @@ -------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-}+-- | Core types used internally module Text.Digestive.Types     ( Result (..)     , resultMapError

@@ -1,4 +1,5 @@ --------------------------------------------------------------------------------+-- | Utilities for safe failable parsing module Text.Digestive.Util     ( readMaybe     ) where

@@ -3,6 +3,14 @@ {-# 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 (..) @@ -37,6 +45,9 @@     , errors     , childErrors +      -- * Further metadata queries+    , viewDisabled+       -- * Debugging     , debugViewPaths     ) where@@ -59,13 +70,15 @@   --------------------------------------------------------------------------------+-- | 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+    { viewName     :: Text+    , viewContext  :: Path+    , viewForm     :: FormTree Identity v m a+    , viewInput    :: [(Path, FormInput)]+    , viewErrors   :: [(Path, v)]+    , viewMethod   :: Method     }  @@ -83,6 +96,7 @@   --------------------------------------------------------------------------------+-- | 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@@ -90,6 +104,8 @@   --------------------------------------------------------------------------------+-- | Handle a form for a POST request - evaluate with the given environment+-- and return the result. postForm :: Monad m => Text -> Form v m a -> Env m -> m (View v, Maybe a) postForm name form env = do     form' <- toFormTree form@@ -101,13 +117,14 @@   --------------------------------------------------------------------------------+-- | 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+          View name (ctx ++ path) notFound (strip input) (strip errs) method         (SomeForm f : _) ->-            View name (ctx ++ path) f (strip input) (strip errs) method+          View name (ctx ++ path) f (strip input) (strip errs) method   where     path     = toPath ref     lpath    = length path@@ -145,16 +162,20 @@   --------------------------------------------------------------------------------+-- | 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'@@ -218,6 +239,8 @@     cur = (fst g, map (\(i, (k, (_, v))) -> (k, v, i == 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'@@ -233,6 +256,7 @@   --------------------------------------------------------------------------------+-- | Return the FilePath referred to by the given serialized path, if set. fieldInputFile :: forall v. Text -> View v -> Maybe FilePath fieldInputFile ref (View _ _ form input _ method) =     queryField path form eval'@@ -248,7 +272,9 @@   ---------------------------------------------------------------------------------listSubViews :: forall v. Text -> View v -> [View v]+-- | 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@@ -281,16 +307,29 @@   --------------------------------------------------------------------------------+-- | 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 :: View v -> [Path] debugViewPaths (View _ _ form _ _ _) = debugFormPaths form

@@ -5,12 +5,22 @@ 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     ]

@@ -0,0 +1,70 @@+{-#LANGUAGE+   FlexibleInstances+  , TypeSynonymInstances+  , GeneralizedNewtypeDeriving+  #-}+-- | Simple tests for applicative laws of the Result type+module Text.Digestive.Field.QTests+       ( tests+       ) where+++--------------------------------------------------------------------------------+import Test.Framework (Test, testGroup)+import Test.QuickCheck hiding (Result, Success)+import Test.Framework.Providers.QuickCheck2 (testProperty)+++--------------------------------------------------------------------------------+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))+

@@ -0,0 +1,50 @@+module Text.Digestive.Form.Encoding.QTests+       ( tests+       ) where++--------------------------------------------------------------------------------+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+++--------------------------------------------------------------------------------+import Text.Digestive.Form.Encoding+++--------------------------------------------------------------------------------+import Data.Monoid+++--------------------------------------------------------------------------------+-- 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]

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

@@ -0,0 +1,106 @@+{-# LANGUAGE+     GADTs+   , OverloadedStrings+   #-}+module Text.Digestive.Form.QTests+       ( tests+       ) where++--------------------------------------------------------------------------------+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck hiding (Success)+++--------------------------------------------------------------------------------+import Text.Digestive.Types+import Text.Digestive.Form.Internal+import Text.Digestive.Form.Internal.Field+++--------------------------------------------------------------------------------+import Data.Text (Text,pack)+import Control.Monad+import Control.Monad.Identity+import Data.Maybe++--------------------------------------------------------------------------------++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, 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

@@ -38,7 +38,9 @@  -------------------------------------------------------------------------------- import           Text.Digestive.Form+import           Text.Digestive.Form.Internal import           Text.Digestive.Types+import           Text.Digestive.View   --------------------------------------------------------------------------------@@ -190,7 +192,8 @@ -------------------------------------------------------------------------------- ordersForm :: Formlet Text Database (Text, [Order]) ordersForm def = (,)-    <$> "name"   .: text             (fst <$> def)+    -- This field is disabled.+    <$> disable ("name"   .: text            (fst <$> def))     -- id is here because of a regression     <*> (id <$> "orders" .: listOf orderForm (snd <$> def)) 

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

@@ -163,6 +163,10 @@         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     ]