diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 --- /dev/null +++ b/CHANGELOG @@ -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 `` + +- 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` diff --git a/digestive-functors.cabal b/digestive-functors.cabal --- a/digestive-functors.cabal +++ b/digestive-functors.cabal @@ -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: - + . + + + . + + 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 @\@ elements; + + . + + * separation of the validation model and the HTML output. + + . + + Tutorial: + + 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 +Maintainer: Jasper Van der Jeugt 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 diff --git a/src/Text/Digestive.hs b/src/Text/Digestive.hs --- a/src/Text/Digestive.hs +++ b/src/Text/Digestive.hs @@ -1,13 +1,26 @@ --- | Module re-exporting all core definitions --- +-------------------------------------------------------------------------------- +-- | Tutorial: +-- 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 + + + diff --git a/src/Text/Digestive/Cli.hs b/src/Text/Digestive/Cli.hs deleted file mode 100644 --- a/src/Text/Digestive/Cli.hs +++ /dev/null @@ -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 diff --git a/src/Text/Digestive/Common.hs b/src/Text/Digestive/Common.hs deleted file mode 100644 --- a/src/Text/Digestive/Common.hs +++ /dev/null @@ -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 ())) diff --git a/src/Text/Digestive/Form.hs b/src/Text/Digestive/Form.hs new file mode 100644 --- /dev/null +++ b/src/Text/Digestive/Form.hs @@ -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 + + diff --git a/src/Text/Digestive/Form/Encoding.hs b/src/Text/Digestive/Form/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/Text/Digestive/Form/Encoding.hs @@ -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: +-- +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 diff --git a/src/Text/Digestive/Form/Internal.hs b/src/Text/Digestive/Form/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Text/Digestive/Form/Internal.hs @@ -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 "] -- 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 diff --git a/src/Text/Digestive/Form/Internal/Field.hs b/src/Text/Digestive/Form/Internal/Field.hs new file mode 100644 --- /dev/null +++ b/src/Text/Digestive/Form/Internal/Field.hs @@ -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 @@ 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 diff --git a/src/Text/Digestive/Form/List.hs b/src/Text/Digestive/Form/List.hs new file mode 100644 --- /dev/null +++ b/src/Text/Digestive/Form/List.hs @@ -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 diff --git a/src/Text/Digestive/Forms.hs b/src/Text/Digestive/Forms.hs deleted file mode 100644 --- a/src/Text/Digestive/Forms.hs +++ /dev/null @@ -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 diff --git a/src/Text/Digestive/Forms/Html.hs b/src/Text/Digestive/Forms/Html.hs deleted file mode 100644 --- a/src/Text/Digestive/Forms/Html.hs +++ /dev/null @@ -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 diff --git a/src/Text/Digestive/Ref.hs b/src/Text/Digestive/Ref.hs new file mode 100644 --- /dev/null +++ b/src/Text/Digestive/Ref.hs @@ -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 ..] diff --git a/src/Text/Digestive/Result.hs b/src/Text/Digestive/Result.hs deleted file mode 100644 --- a/src/Text/Digestive/Result.hs +++ /dev/null @@ -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) diff --git a/src/Text/Digestive/Transform.hs b/src/Text/Digestive/Transform.hs deleted file mode 100644 --- a/src/Text/Digestive/Transform.hs +++ /dev/null @@ -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 diff --git a/src/Text/Digestive/Types.hs b/src/Text/Digestive/Types.hs --- a/src/Text/Digestive/Types.hs +++ b/src/Text/Digestive/Types.hs @@ -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] diff --git a/src/Text/Digestive/Util.hs b/src/Text/Digestive/Util.hs new file mode 100644 --- /dev/null +++ b/src/Text/Digestive/Util.hs @@ -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] diff --git a/src/Text/Digestive/Validate.hs b/src/Text/Digestive/Validate.hs deleted file mode 100644 --- a/src/Text/Digestive/Validate.hs +++ /dev/null @@ -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'] diff --git a/src/Text/Digestive/View.hs b/src/Text/Digestive/View.hs new file mode 100644 --- /dev/null +++ b/src/Text/Digestive/View.hs @@ -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 diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs new file mode 100644 --- /dev/null +++ b/tests/TestSuite.hs @@ -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 + ] diff --git a/tests/Text/Digestive/Field/QTests.hs b/tests/Text/Digestive/Field/QTests.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Digestive/Field/QTests.hs @@ -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)) + diff --git a/tests/Text/Digestive/Field/Tests.hs b/tests/Text/Digestive/Field/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Digestive/Field/Tests.hs @@ -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) + ] diff --git a/tests/Text/Digestive/Form/Encoding/QTests.hs b/tests/Text/Digestive/Form/Encoding/QTests.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Digestive/Form/Encoding/QTests.hs @@ -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] diff --git a/tests/Text/Digestive/Form/Encoding/Tests.hs b/tests/Text/Digestive/Form/Encoding/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Digestive/Form/Encoding/Tests.hs @@ -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 diff --git a/tests/Text/Digestive/Form/List/QTests.hs b/tests/Text/Digestive/Form/List/QTests.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Digestive/Form/List/QTests.hs @@ -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 diff --git a/tests/Text/Digestive/Form/QTests.hs b/tests/Text/Digestive/Form/QTests.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Digestive/Form/QTests.hs @@ -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 diff --git a/tests/Text/Digestive/Tests/Fixtures.hs b/tests/Text/Digestive/Tests/Fixtures.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Digestive/Tests/Fixtures.hs @@ -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 diff --git a/tests/Text/Digestive/Types/QTests.hs b/tests/Text/Digestive/Types/QTests.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Digestive/Types/QTests.hs @@ -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 diff --git a/tests/Text/Digestive/View/Tests.hs b/tests/Text/Digestive/View/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Text/Digestive/View/Tests.hs @@ -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]