diff --git a/Control/Applicative/Indexed.hs b/Control/Applicative/Indexed.hs new file mode 100644 --- /dev/null +++ b/Control/Applicative/Indexed.hs @@ -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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/Reform.hs b/Text/Reform.hs new file mode 100644 --- /dev/null +++ b/Text/Reform.hs @@ -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 diff --git a/Text/Reform/Backend.hs b/Text/Reform/Backend.hs new file mode 100644 --- /dev/null +++ b/Text/Reform/Backend.hs @@ -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) diff --git a/Text/Reform/Core.hs b/Text/Reform/Core.hs new file mode 100644 --- /dev/null +++ b/Text/Reform/Core.hs @@ -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 @\@ 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 @\