reform-0.2.7.5/ 0000755 0000000 0000000 00000000000 07346545000 011346 5 ustar 00 0000000 0000000 reform-0.2.7.5/Control/Applicative/ 0000755 0000000 0000000 00000000000 07346545000 015227 5 ustar 00 0000000 0000000 reform-0.2.7.5/Control/Applicative/Indexed.hs 0000644 0000000 0000000 00000006545 07346545000 017155 0 ustar 00 0000000 0000000 {-# 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/LICENSE 0000644 0000000 0000000 00000002757 07346545000 012366 0 ustar 00 0000000 0000000 Copyright (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.hs 0000644 0000000 0000000 00000000056 07346545000 013003 0 ustar 00 0000000 0000000 import Distribution.Simple
main = defaultMain
reform-0.2.7.5/Text/ 0000755 0000000 0000000 00000000000 07346545000 012272 5 ustar 00 0000000 0000000 reform-0.2.7.5/Text/Reform.hs 0000644 0000000 0000000 00000000464 07346545000 014064 0 ustar 00 0000000 0000000 module 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/ 0000755 0000000 0000000 00000000000 07346545000 013524 5 ustar 00 0000000 0000000 reform-0.2.7.5/Text/Reform/Backend.hs 0000644 0000000 0000000 00000006664 07346545000 015423 0 ustar 00 0000000 0000000 {-# 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.hs 0000644 0000000 0000000 00000033507 07346545000 014760 0 ustar 00 0000000 0000000 {-# 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 @\