State.lhs

> {-|
>     The state contains mutable environmental variables such as posted form fields,
>     field validators and the session
> -}
> module Frame.State (
>  Vars (..),
>  FrameState,
>  FrameReader,
>  get,
>  put,
>  gets,
>  startState,
>  setPost,
>  getField,
>  putFields,
>  mergeFields,
>  putField,
>  delField,
>  -- * Validators
>  getValidator,
>  putValidators,
>  putValidator
> ) where

> import Prelude hiding (lookup)
> import Data.Map
> import qualified Control.Monad.State as S (gets, get, put)
> import Control.Monad.State hiding (gets, get, put)

> import Frame.Config
> import Frame.Types
> import Frame.Validation

> -- | The state record
> data Vars = Vars { 
>                    fields :: Fields         -- ^ Posted fields
>                  , validators :: Validators -- ^ Field validation functions
>                  , post :: Bool             -- ^ Has a form been posted?
>                  , session :: Fields        -- ^ Session fields
>                  , ajax :: Bool             -- ^ Is this an AJAX request?
>                  }

> class (Monad m) => MonadStateGet s m | m -> s where
>     -- | Provides get access to the state, mirroring Control.Monad.State.get
>     get :: m s
> instance (Monad m) => MonadStateGet s (StateT s m) where
>     get   = S.get

> class (Monad m) => MonadStatePut s m | m -> s where
>     -- | Provides get access to the state, mirroring Control.Monad.State.put
>     put :: s -> m ()
> instance (Monad m) => MonadStatePut s (StateT s m) where
>     put  = S.put

> -- | Gets a specific component from the state, using the supplied projection function
> gets :: (MonadStateGet s m) => (s -> a) -- ^ State projection function
>                             -> m a      -- ^ Projected component
> gets f = do
>     s <- get
>     return (f s)

> class (MonadStateGet Vars m, MonadStatePut Vars m) => FrameState m
> instance (MonadStateGet Vars m, MonadStatePut Vars m) => FrameState m

> class (MonadStateGet Vars m) => FrameReader m
> instance (MonadStateGet Vars m) => FrameReader m

> -- | A default empty start state
> startState :: Vars
> startState = Vars {fields = empty, validators = empty, post = False, session = empty, ajax = False}

> setPost :: FrameState m => Bool -> m ()
> setPost b = do
>     v <- get
>     put v {post=b}

> -- | Looks up a specific field in the state by the given field name
> getField :: FrameReader m => FieldName             -- ^ FieldName to be looked up
>                           -> m (Maybe WrapperType) -- ^ The field (if found)
> getField fn = do
>                  fs <- gets fields
>                  return $ lookup fn fs

> -- | Deletes a specific field in the state by the given field name
> delField :: FrameState m 
>          => FieldName -- ^ FieldName to be deleted
>          -> m ()
> delField fn = do
>                    fs <- gets fields
>                    v <- get
>                    put v {fields=delete fn fs}

> -- | Replaces the fields in the state
> putFields :: FrameState m => Fields -- ^ Fields to replace with
>                           -> m ()   -- ^ Nothing (but the modified state) is returned
> putFields fs = do 
>                   v <- get
>                   put v {fields=fs}

> -- | Merges the given fields with the existing state (existing state fields are favoured)
> mergeFields :: FrameState m => Maybe Fields -- ^ Fields to merge
>                             -> m ()         -- ^ Nothing (but the modified state) is returned
> mergeFields Nothing = return ()
> mergeFields (Just fs') = do
>                            fs <- gets fields
>                            putFields $ union fs fs'

> -- | Associate a value with a FieldName in the state
> putField :: (FrameState m, FrameConfig m, Wrappable a) 
>          => FieldName -- ^ The FieldName of the field being updated
>          -> a         -- ^ The (wrappable) field to update state with
>          -> m ()      -- ^ Nothing (but the modified state) is returned
> putField fn f = do
>                    db <- asks database
>                    fs <- gets fields
>                    v <- get
>                    put v {fields=insert fn (wrap db fn f) fs}

> -- | Look up validators functions for a particular field
> getValidator :: FrameReader m => FieldName                               -- ^ Validators to look up
>                               -> m (Maybe [WrapperType -> Maybe String]) -- ^ The validator functions (if found)
> getValidator fn = do
>                  vs <- gets validators
>                  return $ lookup fn vs

> -- | Replaces the Validators in the state
> putValidators :: FrameState m => Validators -- ^ Validators to replace with
>                               -> m ()       -- ^ Nothing (but the modified state) is returned
> putValidators vs = do
>                        v <- get
>                        put v {validators=vs}

> -- | Associate a set of validator functions with a FieldName in the state
> putValidator :: FrameState m => FieldName                    -- ^ The FieldName of the validator being updated
>                             -> [WrapperType -> Maybe String] -- ^ The validator functions to update state with
>                             -> m ()                          -- ^ Nothing (but the modified state) is returned
> putValidator fn ms = do
>                          vs <- gets validators
>                          v <- get
>                          put v {validators=insert fn ms vs}