reform (empty) → 0.1.1
raw patch · 10 files changed
+1137/−0 lines, 10 filesdep +basedep +containersdep +mtlsetup-changed
Dependencies added: base, containers, mtl, text
Files
- Control/Applicative/Indexed.hs +81/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- Text/Reform.hs +14/−0
- Text/Reform/Backend.hs +84/−0
- Text/Reform/Core.hs +354/−0
- Text/Reform/Generalized.hs +283/−0
- Text/Reform/Proof.hs +134/−0
- Text/Reform/Result.hs +120/−0
- reform.cabal +35/−0
+ Control/Applicative/Indexed.hs view
@@ -0,0 +1,81 @@+{-# 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)
+ LICENSE view
@@ -0,0 +1,30 @@+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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/Reform.hs view
@@ -0,0 +1,14 @@+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
+ Text/Reform/Backend.hs view
@@ -0,0 +1,84 @@+{-# 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)
+ Text/Reform/Core.hs view
@@ -0,0 +1,354 @@+{-# 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 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+ -> String+ -> 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 prefix))++-- | Run a form+--+runForm' :: (Monad m) =>+ Environment m input+ -> String+ -> 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) =>+ String -- ^ 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+ -> String -- ^ 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 @\<br\>@ 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 @\<label+-- for=\"someid\"\>@, which need to refer to the id of another+-- element.+(++>) :: (Monad m, Monoid view)+ => Form m input error view () ()+ -> Form m input error view proof a+ -> Form m input error view proof 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 ++>++-- | Append a unit form to the right. See '++>'.+--+(<++) :: (Monad m, Monoid view)+ => Form m input error view proof a+ -> Form m input error view () ()+ -> Form m input error view proof 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 <++++-- | Change the view of a form using a simple function+--+-- This is useful for wrapping a form inside of a \<fieldset\> or other markup element.+mapView :: (Monad m, Functor m)+ => (view -> view') -- ^ Manipulator+ -> Form m input error view proof a -- ^ Initial form+ -> Form m input error view' proof a -- ^ Resulting form+mapView f = Form . fmap (first $ fmap f) . unForm++-- | Utility Function: turn a view and return value into a successful 'FormState'+mkOk :: (Monad m) =>+ FormId+ -> view+ -> a+ -> FormState m input (View error view, m (Result error (Proved () a)))+mkOk i view val =+ return ( View $ const $ view+ , return $ Ok (Proved { proofs = ()+ , pos = unitRange i+ , unProved = val+ })+ )
+ Text/Reform/Generalized.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE ScopedTypeVariables, TypeFamilies, ViewPatterns #-}+{- |+This module provides helper functions for HTML input elements. These helper functions are not specific to any particular web framework or html library.+-}+module Text.Reform.Generalized where++import Control.Applicative ((<$>))+import qualified Data.IntSet as IS+import Data.List (find)+import Data.Maybe (mapMaybe)+import Numeric (readDec)+import Text.Reform.Backend+import Text.Reform.Core+import Text.Reform.Result++-- | used for constructing elements like @\<input type=\"text\"\>@, which return a single input value.+input :: (Monad m, FormError error) =>+ (input -> Either error a)+ -> (FormId -> a -> view)+ -> a+ -> Form m input error view () a+input fromInput toView initialValue =+ Form $ do i <- getFormId+ v <- getFormInput' i+ case v of+ Default ->+ return ( View $ const $ toView i initialValue+ , return $ Ok (Proved { proofs = ()+ , pos = unitRange i+ , unProved = initialValue+ }))+ (Found (fromInput -> (Right a))) ->+ return ( View $ const $ toView i a+ , return $ Ok (Proved { proofs = ()+ , pos = unitRange i+ , unProved = a+ }))+ (Found (fromInput -> (Left error))) ->+ return ( View $ const $ toView i initialValue+ , return $ Error [(unitRange i, error)]+ )+ Missing ->+ return ( View $ const $ toView i initialValue+ , return $ Error [(unitRange i, commonFormError (InputMissing i))]+ )++-- | used for elements like @\<input type=\"submit\"\>@ which are not always present in the form submission data.+inputMaybe :: (Monad m, FormError error) =>+ (input -> Either error a)+ -> (FormId -> a -> view)+ -> a+ -> Form m input error view () (Maybe a)+inputMaybe fromInput toView initialValue =+ Form $ do i <- getFormId+ v <- getFormInput' i+ case v of+ Default ->+ return ( View $ const $ toView i initialValue+ , return $ Ok (Proved { proofs = ()+ , pos = unitRange i+ , unProved = Just initialValue+ }))+ (Found (fromInput -> (Right a))) ->+ return ( View $ const $ toView i a+ , return $ Ok (Proved { proofs = ()+ , pos = unitRange i+ , unProved = (Just a)+ }))+ (Found (fromInput -> (Left error))) ->+ return ( View $ const $ toView i initialValue+ , return $ Error [(unitRange i, error)]+ )+ Missing ->+ return ( View $ const $ toView i initialValue+ , return $ Ok (Proved { proofs = ()+ , pos = unitRange i+ , unProved = Nothing+ })+ )++-- | used for elements like @\<input type=\"reset\"\>@ which take a value, but are never present in the form data set.+inputNoData :: (Monad m) =>+ (FormId -> a -> view)+ -> a+ -> Form m input error view () ()+inputNoData toView a =+ Form $ do i <- getFormId+ return ( View $ const $ toView i a+ , return $ Ok (Proved { proofs = ()+ , pos = unitRange i+ , unProved = ()+ })+ )++-- | used for @\<input type=\"file\"\>@+inputFile :: forall m input error view. (Monad m, FormInput input, FormError error, ErrorInputType error ~ input) =>+ (FormId -> view)+ -> Form m input error view () (FileType input)+inputFile toView =+ Form $ do i <- getFormId+ v <- getFormInput' i+ case v of+ Default ->+ return ( View $ const $ toView i+ , return $ Error [(unitRange i, commonFormError (InputMissing i))]+ )++ (Found (getInputFile' -> (Right a))) ->+ return ( View $ const $ toView i+ , return $ Ok (Proved { proofs = ()+ , pos = unitRange i+ , unProved = a+ }))++ (Found (getInputFile' -> (Left error))) ->+ return ( View $ const $ toView i+ , return $ Error [(unitRange i, error)]+ )+ Missing ->+ return ( View $ const $ toView i+ , return $ Error [(unitRange i, commonFormError (InputMissing i))]+ )+ where+ -- just here for the type-signature to make the type-checker happy+ getInputFile' :: (FormError error, ErrorInputType error ~ input) => input -> Either error (FileType input)+ getInputFile' = getInputFile++-- | used for groups of checkboxes, @\<select multiple=\"multiple\"\>@ boxes+inputMulti :: forall m input error view a lbl. (Functor m, FormError error, ErrorInputType error ~ input, FormInput input, Monad m) =>+ [(a, lbl)] -- ^ value, label, initially checked+ -> (FormId -> [(FormId, Int, lbl, Bool)] -> view) -- ^ function which generates the view+ -> (a -> Bool) -- ^ isChecked/isSelected initially+ -> Form m input error view () [a]+inputMulti choices mkView isSelected =+ Form $ do i <- getFormId+ inp <- getFormInput' i+ case inp of++ Default ->+ do let (choices', vals) = foldr (\(a, lbl) (cs,vs) ->+ if isSelected a+ then ((a, lbl, True) :cs, a:vs)+ else ((a, lbl, False):cs, vs))+ ([],[])+ choices+ view <- mkView i <$> augmentChoices choices'+ mkOk i view vals++ Missing -> -- just means that no checkboxes were checked+ do view <- mkView i <$> augmentChoices (map (\(x,y) -> (x,y,False)) choices)+ mkOk i view []++ (Found v) ->+ do let readDec' str = case readDec str of+ [(n,[])] -> n+ _ -> (-1) -- FIXME: should probably return an internal error?+ keys = IS.fromList $ map readDec' $ getInputStrings v+ (choices', vals) =+ foldr (\(i, (a,lbl)) (c,v) ->+ if IS.member i keys+ then ((a,lbl,True) : c, a : v)+ else ((a,lbl,False): c, v)) ([],[]) $+ zip [0..] choices+ view <- mkView i <$> augmentChoices choices'+ mkOk i view vals+++ where+ augmentChoices :: (Monad m) => [(a, lbl, Bool)] -> FormState m input [(FormId, Int, lbl, Bool)]+ augmentChoices choices = mapM augmentChoice (zip [0..] choices)++ augmentChoice :: (Monad m) => (Int, (a, lbl, Bool)) -> FormState m input (FormId, Int, lbl, Bool)+ augmentChoice (vl, (a, lbl, checked)) =+ do i <- getFormId+ return (i, vl, lbl, checked)+++-- | radio buttons, single @\<select\>@ boxes+inputChoice :: forall a m error input lbl view. (Functor m, FormError error, ErrorInputType error ~ input, FormInput input, Monad m) =>+ (a -> Bool) -- ^ is default+ -> [(a, lbl)] -- ^ value, label+ -> (FormId -> [(FormId, Int, lbl, Bool)] -> view) -- ^ function which generates the view+ -> Form m input error view () a+inputChoice isDefault choices mkView =+ Form $ do i <- getFormId+ inp <- getFormInput' i++ case inp of+ Default ->+ do let (choices', def) = markSelected choices+ view <- mkView i <$> augmentChoices choices'+ mkOk' i view def++ Missing -> -- can happen if no choices where checked+ do let (choices', def) = markSelected choices+ view <- mkView i <$> augmentChoices choices'+ mkOk' i view def++ (Found v) ->+ do let readDec' str = case readDec str of+ [(n,[])] -> n+ _ -> (-1) -- FIXME: should probably return an internal error?+ (Right str) = getInputString v :: Either error String -- FIXME+ key = readDec' str+ (choices', mval) =+ foldr (\(i, (a, lbl)) (c, v) ->+ if i == key+ then ((a,lbl,True) : c, Just a)+ else ((a,lbl,False): c, v))+ ([], Nothing) $+ zip [0..] choices+ view <- mkView i <$> augmentChoices choices'+ case mval of+ Nothing ->+ return ( View $ const $ view+ , return $ Error [(unitRange i, commonFormError (InputMissing i))]+ )+ (Just val) -> mkOk i view val++ where+ mkOk' i view (Just val) = mkOk i view val+ mkOk' i view Nothing =+ return ( View $ const $ view+ , return $ Error [(unitRange i, commonFormError MissingDefaultValue)]+ )++ markSelected :: [(a,lbl)] -> ([(a, lbl, Bool)], Maybe a)+ markSelected cs = foldr (\(a,lbl) (vs, ma) ->+ if isDefault a+ then ((a,lbl,True):vs , Just a)+ else ((a,lbl,False):vs, ma))+ ([], Nothing)+ cs++ augmentChoices :: (Monad m) => [(a, lbl, Bool)] -> FormState m input [(FormId, Int, lbl, Bool)]+ augmentChoices choices = mapM augmentChoice (zip [0..] choices)++ augmentChoice :: (Monad m) => (Int, (a, lbl, Bool)) -> FormState m input (FormId, Int, lbl, Bool)+ augmentChoice (vl, (a, lbl,selected)) =+ do i <- getFormId+ return (i, vl, lbl, selected)++-- | used to create @\<label\>@ elements+label :: Monad m =>+ (FormId -> view)+ -> Form m input error view () ()+label f = Form $ do+ id' <- getFormId+ return ( View (const $ f id')+ , return (Ok $ Proved { proofs = ()+ , pos = unitRange id'+ , unProved = ()+ })+ )+-- | used to add a list of error messages to a 'Form'+--+-- This function automatically takes care of extracting only the+-- errors that are relevent to the form element it is attached to via+-- '<++' or '++>'.+errors :: Monad m =>+ ([error] -> view) -- ^ function to convert the error messages into a view+ -> Form m input error view () ()+errors f = Form $ do+ range <- getFormRange+ return ( View (f . retainErrors range)+ , return (Ok $ Proved { proofs = ()+ , pos = range+ , unProved = ()+ })+ )++-- | similar to 'errors' but includes error messages from children of the form as well.+childErrors :: Monad m =>+ ([error] -> view)+ -> Form m input error view () ()+childErrors f = Form $ do+ range <- getFormRange+ return (View (f . retainChildErrors range)+ , return (Ok $ Proved { proofs = ()+ , pos = range+ , unProved = ()+ })+ )
+ Text/Reform/Proof.hs view
@@ -0,0 +1,134 @@+{- |+This module defines the 'Proof' type, some proofs, and some helper functions.++A 'Proof' does three things:++ - verifies that the input value meets some criteria+ - optionally transforms the input value to another value while preserving that criteria+ - puts the proof name in type-signature where the type-checker can use it+-}+module Text.Reform.Proof where++import Control.Applicative.Indexed (IndexedFunctor(imap))+import Control.Monad.Trans (lift)+import Numeric (readDec, readFloat, readSigned)+import Text.Reform.Result (FormRange, Result(..))+import Text.Reform.Core (Form(..), Proved(..))++-- | A 'Proof' attempts to prove something about a value.+--+-- If successful, it can also transform the value to a new value. The+-- proof should hold for the new value as well.+--+-- Generally, each 'Proof' has a unique data-type associated with it+-- which names the proof, such as:+--+-- > data NotNull = NotNull+--+data Proof m error proof a b+ = Proof { proofName :: proof -- ^ name of the thing to prove+ , proofFunction :: a -> m (Either error b) -- ^ function which provides the proof+ }++-- | apply a 'Proof' to a 'Form'+prove :: (Monad m) =>+ Form m input error view q a+ -> Proof m error proof a b+ -> Form m input error view proof b+prove (Form frm) (Proof p f) =+ Form $ do (xml, mval) <- frm+ val <- lift $ lift $ mval+ case val of+ (Error errs) -> return (xml, return $ Error errs)+ (Ok (Proved _ pos a)) ->+ do r <- lift $ lift $ f a+ case r of+ (Left err) -> return (xml, return $ Error [(pos, err)])+ (Right b) ->+ return (xml, return $ Ok (Proved { proofs = p+ , pos = pos+ , unProved = b+ }))++-- * transformations (proofs minus the proof).++-- | transform a 'Form' using a 'Proof', and the replace the proof with @()@.+--+-- This is useful when you want just want classic digestive-functors behaviour.+transform :: (Monad m) =>+ Form m input error view anyProof a+ -> Proof m error proof a b+ -> Form m input error view () b+transform frm proof = imap (const ()) id (frm `prove` proof)++-- | transform the 'Form' result using a monadic 'Either' function.+transformEitherM :: (Monad m) => Form m input error view anyProof a+ -> (a -> m (Either error b))+ -> Form m input error view () b+transformEitherM frm func = frm `transform` (Proof () func)++-- | transform the 'Form' result using an 'Either' function.+transformEither :: (Monad m) =>+ Form m input error view anyProof a+ -> (a -> Either error b)+ -> Form m input error view () b+transformEither frm func = transformEitherM frm (return . func)++-- * Various Proofs++-- | proof that a list is not empty+data NotNull = NotNull++-- | prove that a list is not empty+notNullProof :: (Monad m) => error -> Proof m error NotNull [a] [a]+notNullProof errorMsg = Proof NotNull (return . check)+ where+ check list =+ if null list+ then (Left errorMsg)+ else (Right list)++-- | proof that a 'String' is a decimal number+data Decimal = Decimal+-- | proof that a 'String' is a Real/Fractional number+data RealFractional = RealFractional+-- | proof that a number is also (allowed to be) signed+data Signed a = Signed a++-- | read an unsigned number in decimal notation+decimal :: (Monad m, Eq i, Num i) =>+ (String -> error) -- ^ create an error message ('String' is the value that did not parse)+ -> Proof m error Decimal String i+decimal mkError = Proof Decimal (return . toDecimal)+ where+ toDecimal str =+ case readDec str of+ [(d,[])] -> (Right d)+ _ -> (Left $ mkError str)++-- | read signed decimal number+signedDecimal :: (Monad m, Eq i, Real i) => (String -> error) -> Proof m error (Signed Decimal) String i+signedDecimal mkError = Proof (Signed Decimal) (return . toDecimal)+ where+ toDecimal str =+ case (readSigned readDec) str of+ [(d,[])] -> (Right d)+ _ -> (Left $ mkError str)++-- | read 'RealFrac' number+realFrac :: (Monad m, RealFrac a) => (String -> error) -> Proof m error RealFractional String a+realFrac mkError = Proof RealFractional (return . toRealFrac)+ where+ toRealFrac str =+ case readFloat str of+ [(f,[])] -> (Right f)+ _ -> (Left $ mkError str)++-- | read a signed 'RealFrac' number+realFracSigned :: (Monad m, RealFrac a) => (String -> error) -> Proof m error (Signed RealFractional) String a+realFracSigned mkError = Proof (Signed RealFractional) (return . toRealFrac)+ where+ toRealFrac str =+ case (readSigned readFloat) str of+ [(f,[])] -> (Right f)+ _ -> (Left $ mkError str)
+ Text/Reform/Result.hs view
@@ -0,0 +1,120 @@+-- | 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.cabal view
@@ -0,0 +1,35 @@+Name: reform+Version: 0.1.1+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 <m@jaspervdj.be>+Maintainer: Jeremy Shaw <jeremy@n-heptane.com>+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://patch-tag.com/r/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.*,+ mtl >= 2.0 && < 2.2,+ text == 0.11.*+