reform-0.2.0/0000755000000000000000000000000012171027104011164 5ustar0000000000000000reform-0.2.0/reform.cabal0000644000000000000000000000262612171027104013450 0ustar0000000000000000Name: reform Version: 0.2.0 Synopsis: reform is an HTML form generation and validation library Description: reform follows in the footsteps of formlets and digestive-functors <= 0.2. It provides a type-safe and composable method for generating an HTML form that includes validation. License: BSD3 License-file: LICENSE Author: Jeremy Shaw, Jasper Van der Jeugt Maintainer: Jeremy Shaw Copyright: 2012 Jeremy Shaw, Jasper Van der Jeugt, SeeReason Partners LLC Category: Web Build-type: Simple Homepage: http://www.happstack.com/ Cabal-version: >=1.6 source-repository head type: darcs subdir: reform location: http://hub.darcs.net/stepcut/reform Library Exposed-modules: Control.Applicative.Indexed Text.Reform Text.Reform.Backend Text.Reform.Core Text.Reform.Generalized Text.Reform.Proof Text.Reform.Result Build-depends: base >= 4 && <5, containers >= 0.4 && < 0.6, mtl >= 2.0 && < 2.2, text == 0.11.* reform-0.2.0/LICENSE0000644000000000000000000000275712171027104012204 0ustar0000000000000000Copyright (c)2012, Jeremy Shaw All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Jeremy Shaw nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. reform-0.2.0/Setup.hs0000644000000000000000000000005612171027104012621 0ustar0000000000000000import Distribution.Simple main = defaultMain reform-0.2.0/Control/0000755000000000000000000000000012171027104012604 5ustar0000000000000000reform-0.2.0/Control/Applicative/0000755000000000000000000000000012171027104015045 5ustar0000000000000000reform-0.2.0/Control/Applicative/Indexed.hs0000644000000000000000000000654512171027104016773 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | This module provides a type-indexed / parameterized version of the 'Functor' and 'Applicative' classes. -} module Control.Applicative.Indexed where import Control.Applicative (Applicative(pure, (<*>))) ------------------------------------------------------------------------------ -- * type-indexed / parameterized classes ------------------------------------------------------------------------------ -- | a class for a 'type-indexed' or 'paramaterized' functor -- -- note: not sure what the most correct name is for this class, or if -- it exists in a well supported library already. class IndexedFunctor f where -- | imap is similar to fmap imap :: (x -> y) -- ^ function to apply to first parameter -> (a -> b) -- ^ function to apply to second parameter -> f x a -- ^ indexed functor -> f y b -- | a class for a 'type-indexed' or 'paramaterized' applicative functors -- -- note: not sure what the most correct name is for this class, or if -- it exists in a well supported library already. class (IndexedFunctor f) => IndexedApplicative f where -- | similar to 'pure' ipure :: x -> a -> f x a -- | similar to '<*>' (<<*>>) :: f (x -> y) (a -> b) -> f x a -> f y b -- | similar to 'Control.Applicative.*>' (*>>) :: f x a -> f y b -> f y b (*>>) = liftIA2 (const id) (const id) -- | similar to 'Control.Applicative.<*' (<<*) :: f x a -> f y b -> f x a (<<*) = liftIA2 const const infixl 4 <<*>>, <<*, *>> -- , <<**>> -- | similar to 'Data.Functor.<$>'. An alias for @imap id@ (<<$>>) :: IndexedFunctor f => (a -> b) -> f y a -> f y b (<<$>>) = imap id infixl 4 <<$>> -- | A variant of '<<*>>' with the arguments reversed. (<<**>>) :: (IndexedApplicative f) => f x a -> f (x -> y) (a -> b) -> f y b (<<**>>) = liftIA2 (flip ($)) (flip ($)) -- | Lift a function to actions. -- This function may be used as a value for `imap` in a `IndexedFunctor` instance. liftIA :: (IndexedApplicative f) => (a -> b) -> (x -> y) -> f a x -> f b y liftIA f g a = ipure f g <<*>> a -- | Lift a binary function to actions. liftIA2 :: (IndexedApplicative f) => (a -> b -> c) -> (x -> y -> z) -> f a x -> f b y -> f c z liftIA2 f g a b = ipure f g <<*>> a <<*>> b -- | Lift a binary function to actions. liftIA3 :: (IndexedApplicative f) => (a -> b -> c -> d) -> (w -> x -> y -> z) -> f a w -> f b x -> f c y -> f d z liftIA3 f g a b c = ipure f g <<*>> a <<*>> b <<*>> c ------------------------------------------------------------------------------ -- * WrappedApplicative ------------------------------------------------------------------------------ -- | a wrapper which lifts a value with an 'Applicative' instance so that it can be used as an 'IndexedFunctor' or 'IndexedApplicative' -- -- > d :: WrappedApplicative Maybe y Char -- > d = WrappedApplicative (Just succ) <<*>> WrappedApplicative (Just 'c') newtype WrappedApplicative f index a = WrappedApplicative { unwrapApplicative :: f a } deriving (Functor, Applicative, Monad, Eq, Ord, Read, Show) instance (Functor f) => IndexedFunctor (WrappedApplicative f) where imap f g (WrappedApplicative a) = WrappedApplicative (fmap g a) instance (Applicative f) => IndexedApplicative (WrappedApplicative f) where ipure x a = WrappedApplicative (pure a) (WrappedApplicative f) <<*>> (WrappedApplicative a) = WrappedApplicative (f <*> a) reform-0.2.0/Text/0000755000000000000000000000000012171027104012110 5ustar0000000000000000reform-0.2.0/Text/Reform.hs0000644000000000000000000000046412171027104013702 0ustar0000000000000000module Text.Reform ( module Data.Monoid , module Text.Reform.Backend , module Text.Reform.Core , module Text.Reform.Result , module Text.Reform.Proof ) where import Data.Monoid import Text.Reform.Backend import Text.Reform.Core import Text.Reform.Result import Text.Reform.Proof reform-0.2.0/Text/Reform/0000755000000000000000000000000012171027104013342 5ustar0000000000000000reform-0.2.0/Text/Reform/Result.hs0000644000000000000000000000633012171027104015156 0ustar0000000000000000-- | Module for the core result type, and related functions -- module Text.Reform.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 -- | convert a 'Result' to 'Maybe' discarding the error message on 'Error' 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] } -- | map a function over the @[Integer]@ inside a 'FormId' 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) ++ "]" -- | get the head 'Integer' from a 'FormId' 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" -- | create a 'FormRange' from a 'FormId' 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) reform-0.2.0/Text/Reform/Core.hs0000644000000000000000000003324712171027104014577 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving #-} {- | This module defines the 'Form' type, its instances, core manipulation functions, and a bunch of helper utilities. -} module Text.Reform.Core where import Control.Applicative (Applicative(pure, (<*>))) import Control.Applicative.Indexed (IndexedApplicative(ipure, (<<*>>)), IndexedFunctor (imap)) import Control.Arrow (first, second) import Control.Monad.Reader (MonadReader(ask), ReaderT, runReaderT) import Control.Monad.State (MonadState(get,put), StateT, evalStateT) import Control.Monad.Trans (lift) import Data.Monoid (Monoid(mempty, mappend)) import Data.Text.Lazy (Text, unpack) import Text.Reform.Result (FormId(..), FormRange(..), Result(..), unitRange, zeroId) ------------------------------------------------------------------------------ -- * Proved ------------------------------------------------------------------------------ -- | Proved records a value, the location that value came from, and something that was proved about the value. data Proved proofs a = Proved { proofs :: proofs , pos :: FormRange , unProved :: a } instance Functor (Proved ()) where fmap f (Proved () pos a) = Proved () pos (f a) -- | Utility Function: trivially prove nothing about () unitProved :: FormId -> Proved () () unitProved formId = Proved { proofs = () , pos = unitRange formId , unProved = () } ------------------------------------------------------------------------------ -- * FormState ------------------------------------------------------------------------------ -- | inner state used by 'Form'. type FormState m input = ReaderT (Environment m input) (StateT FormRange m) -- | used to represent whether a value was found in the form -- submission data, missing from the form submission data, or expected -- that the default value should be used data Value a = Default | Missing | Found a -- | Utility function: Get the current input -- getFormInput :: Monad m => FormState m input (Value input) getFormInput = getFormId >>= getFormInput' -- | Utility function: Gets the input of an arbitrary 'FormId'. -- getFormInput' :: Monad m => FormId -> FormState m input (Value input) getFormInput' id' = do env <- ask case env of NoEnvironment -> return Default Environment f -> lift $ lift $ f id' -- | Utility function: Get the current range -- getFormRange :: Monad m => FormState m i FormRange getFormRange = get -- | The environment is where you get the actual input per form. -- -- The 'NoEnvironment' constructor is typically used when generating a -- view for a GET request, where no data has yet been submitted. This -- will cause the input elements to use their supplied default values. -- -- Note that 'NoEnviroment' is different than supplying an empty environment. data Environment m input = Environment (FormId -> m (Value input)) | NoEnvironment -- | Not quite sure when this is useful and so hard to say if the rules for combining things with Missing/Default are correct instance (Monoid input, Monad m) => Monoid (Environment m input) where mempty = NoEnvironment NoEnvironment `mappend` x = x x `mappend` NoEnvironment = x (Environment env1) `mappend` (Environment env2) = Environment $ \id' -> do r1 <- (env1 id') r2 <- (env2 id') case (r1, r2) of (Missing, Missing) -> return Missing (Default, Missing) -> return Default (Missing, Default) -> return Default (Found x, Found y) -> return $ Found (x `mappend` y) (Found x, _ ) -> return $ Found x (_ , Found y) -> return $ Found y -- | 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: increment the current 'FormId'. incFormId :: Monad m => FormState m i () incFormId = do FormRange _ endF1 <- get put $ unitRange endF1 -- | 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 error v = View { unView :: [(FormRange, error)] -> v } deriving (Monoid) instance Functor (View e) where fmap f (View g) = View $ f . g ------------------------------------------------------------------------------ -- * Form ------------------------------------------------------------------------------ -- | a 'Form' contains a 'View' combined with a validation function -- which will attempt to extract a value from submitted form data. -- -- It is highly parameterized, allowing it work in a wide variety of -- different configurations. You will likely want to make a type alias -- that is specific to your application to make type signatures more -- manageable. -- -- [@m@] A monad which can be used by the validator -- -- [@input@] A framework specific type for representing the raw key/value pairs from the form data -- -- [@error@] A application specific type for error messages -- -- [@view@] The type of data being generated for the view (HSP, Blaze Html, Heist, etc) -- -- [@proof@] A type which names what has been proved about the return value. @()@ means nothing has been proved. -- -- [@a@] Value return by form when it is successfully decoded, validated, etc. -- -- -- This type is very similar to the 'Form' type from -- @digestive-functors <= 0.2@. If @proof@ is @()@, then 'Form' is an -- applicative functor and can be used almost exactly like -- @digestive-functors <= 0.2@. newtype Form m input error view proof a = Form { unForm :: FormState m input (View error view, m (Result error (Proved proof a))) } instance (Monad m) => IndexedFunctor (Form m input view error) where imap f g (Form frm) = Form $ do (view, mval) <- frm val <- lift $ lift $ mval case val of (Ok (Proved p pos a)) -> return (view, return $ Ok (Proved (f p) pos (g a))) (Error errs) -> return (view, return $ Error errs) instance (Monoid view, Monad m) => IndexedApplicative (Form m input error view) where ipure p a = Form $ do i <- getFormId return (mempty, return $ Ok (Proved p (unitRange i) a)) (Form frmF) <<*>> (Form frmA) = Form $ do ((view1, mfok), (view2, maok)) <- bracketState $ do res1 <- frmF incFormId res2 <- frmA return (res1, res2) fok <- lift $ lift $ mfok aok <- lift $ lift $ maok case (fok, aok) of (Error errs1, Error errs2) -> return (view1 `mappend` view2, return $ Error $ errs1 ++ errs2) (Error errs1, _) -> return (view1 `mappend` view2, return $ Error $ errs1) (_ , Error errs2) -> return (view1 `mappend` view2, return $ Error $ errs2) (Ok (Proved p (FormRange x _) f), Ok (Proved q (FormRange _ y) a)) -> return (view1 `mappend` view2, return $ Ok $ Proved { proofs = p q , pos = FormRange x y , unProved = f a }) bracketState :: Monad m => FormState m input a -> FormState m input a bracketState k = do FormRange startF1 _ <- get res <- k FormRange _ endF2 <- get put $ FormRange startF1 endF2 return res instance (Functor m) => Functor (Form m input error view ()) where fmap f form = Form $ fmap (second (fmap (fmap (fmap f)))) (unForm form) instance (Functor m, Monoid view, Monad m) => Applicative (Form m input error view ()) where pure a = Form $ do i <- getFormId return (View $ const $ mempty, return $ Ok $ Proved { proofs = () , pos = FormRange i i , unProved = a }) -- this coud be defined in terms of <<*>> if we just changed the proof of frmF to (() -> ()) (Form frmF) <*> (Form frmA) = Form $ do ((view1, mfok), (view2, maok)) <- bracketState $ do res1 <- frmF incFormId res2 <- frmA return (res1, res2) fok <- lift $ lift $ mfok aok <- lift $ lift $ maok case (fok, aok) of (Error errs1, Error errs2) -> return (view1 `mappend` view2, return $ Error $ errs1 ++ errs2) (Error errs1, _) -> return (view1 `mappend` view2, return $ Error $ errs1) (_ , Error errs2) -> return (view1 `mappend` view2, return $ Error $ errs2) (Ok (Proved p (FormRange x _) f), Ok (Proved q (FormRange _ y) a)) -> return (view1 `mappend` view2, return $ Ok $ Proved { proofs = () , pos = FormRange x y , unProved = f a }) -- ** Ways to evaluate a Form -- | Run a form -- runForm :: (Monad m) => Environment m input -> Text -> Form m input error view proof a -> m (View error view, m (Result error (Proved proof a))) runForm env prefix' form = evalStateT (runReaderT (unForm form) env) (unitRange (zeroId $ unpack prefix')) -- | Run a form -- runForm' :: (Monad m) => Environment m input -> Text -> Form m input error view proof a -> m (view , Maybe a) runForm' env prefix form = do (view', mresult) <- runForm env prefix form result <- mresult return $ case result of Error e -> (unView view' e , Nothing) Ok x -> (unView view' [], Just (unProved x)) -- | Just evaluate the form to a view. This usually maps to a GET request in the -- browser. -- viewForm :: (Monad m) => Text -- ^ form prefix -> Form m input error view proof a -- ^ form to view -> m view viewForm prefix form = do (v, _) <- runForm NoEnvironment prefix form return (unView v []) -- | Evaluate a form -- -- Returns: -- -- [@Left view@] on failure. The @view@ will have already been applied to the errors. -- -- [@Right a@] on success. -- eitherForm :: (Monad m) => Environment m input -- ^ Input environment -> Text -- ^ Identifier for the form -> Form m input error view proof a -- ^ Form to run -> m (Either view a) -- ^ Result eitherForm env id' form = do (view', mresult) <- runForm env id' form result <- mresult return $ case result of Error e -> Left $ unView view' e Ok x -> Right (unProved x) -- | create a 'Form' from some @view@. -- -- This is typically used to turn markup like @\@ into a 'Form'. view :: (Monad m) => view -- ^ View to insert -> Form m input error view () () -- ^ Resulting form view view' = Form $ do i <- getFormId return ( View (const view') , return (Ok (Proved { proofs = () , pos = FormRange i i , unProved = () }))) -- | Append a unit form to the left. This is useful for adding labels or error -- fields. -- -- The 'Forms' on the left and right hand side will share the same -- 'FormId'. This is useful for elements like @\