> {-| > 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}