reform-0.2.7.5/0000755000000000000000000000000007346545000011346 5ustar0000000000000000reform-0.2.7.5/Control/Applicative/0000755000000000000000000000000007346545000015227 5ustar0000000000000000reform-0.2.7.5/Control/Applicative/Indexed.hs0000644000000000000000000000654507346545000017155 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.7.5/LICENSE0000644000000000000000000000275707346545000012366 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.7.5/Setup.hs0000644000000000000000000000005607346545000013003 0ustar0000000000000000import Distribution.Simple main = defaultMain reform-0.2.7.5/Text/0000755000000000000000000000000007346545000012272 5ustar0000000000000000reform-0.2.7.5/Text/Reform.hs0000644000000000000000000000046407346545000014064 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.7.5/Text/Reform/0000755000000000000000000000000007346545000013524 5ustar0000000000000000reform-0.2.7.5/Text/Reform/Backend.hs0000644000000000000000000000666407346545000015423 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-} {- | This module contains two classes. 'FormInput' is a class which is parameterized over the @input@ type used to represent form data in different web frameworks. There should be one instance for each framework, such as Happstack, Snap, WAI, etc. The 'FormError' class is used to map error messages into an application specific error type. -} module Text.Reform.Backend where import Data.Maybe (listToMaybe) import Data.Text (Text) import qualified Data.Text as T import Text.Reform.Result (FormId) -- | an error type used to represent errors that are common to all backends -- -- These errors should only occur if there is a bug in the reform-* -- packages. Perhaps we should make them an 'Exception' so that we can -- get rid of the 'FormError' class. data CommonFormError input = InputMissing FormId | NoStringFound input | NoFileFound input | MultiFilesFound input | MultiStringsFound input | MissingDefaultValue deriving (Eq, Ord, Show) -- | some default error messages for 'CommonFormError' commonFormErrorStr :: (input -> String) -- ^ show 'input' in a format suitable for error messages -> CommonFormError input -- ^ a 'CommonFormError' -> String commonFormErrorStr showInput cfe = case cfe of (InputMissing formId) -> "Input field missing for " ++ show formId (NoStringFound input) -> "Could not extract a string value from: " ++ showInput input (NoFileFound input) -> "Could not find a file associated with: " ++ showInput input (MultiFilesFound input) -> "Found multiple files associated with: " ++ showInput input (MultiStringsFound input) -> "Found multiple strings associated with: " ++ showInput input MissingDefaultValue -> "Missing default value." -- | A Class to lift a 'CommonFormError' into an application-specific error type class FormError e where type ErrorInputType e commonFormError :: (CommonFormError (ErrorInputType e)) -> e -- | Class which all backends should implement. -- class FormInput input where -- |@input@ is here the type that is used to represent a value -- uploaded by the client in the request. type FileType input -- | Parse the input into a string. This is used for simple text fields -- among other things -- getInputString :: (FormError error, ErrorInputType error ~ input) => input -> Either error String getInputString input = case getInputStrings input of [] -> Left (commonFormError $ NoStringFound input) [s] -> Right s _ -> Left (commonFormError $ MultiStringsFound input) -- | Should be implemented -- getInputStrings :: input -> [String] -- | Parse the input value into 'Text' -- getInputText :: (FormError error, ErrorInputType error ~ input) => input -> Either error Text getInputText input = case getInputTexts input of [] -> Left (commonFormError $ NoStringFound input) [s] -> Right s _ -> Left (commonFormError $ MultiStringsFound input) -- | Can be overriden for efficiency concerns -- getInputTexts :: input -> [Text] getInputTexts = map T.pack . getInputStrings -- | Get a file descriptor for an uploaded file -- getInputFile :: (FormError error, ErrorInputType error ~ input) => input -> Either error (FileType input) reform-0.2.7.5/Text/Reform/Core.hs0000644000000000000000000003350707346545000014760 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 qualified Data.Semigroup as SG 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 } deriving Show 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 instance (SG.Semigroup input, Monad m) => SG.Semigroup (Environment m input) where NoEnvironment <> x = x x <> NoEnvironment = x (Environment env1) <> (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 SG.<> y) (Found x, _ ) -> return $ Found x (_ , Found y) -> return $ Found y -- | Not quite sure when this is useful and so hard to say if the rules for combining things with Missing/Default are correct instance (SG.Semigroup input, Monad m) => Monoid (Environment m input) where mempty = NoEnvironment mappend = (SG.<>) -- | 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 (SG.Semigroup, 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 @\