>
> module Frame.State (
> Vars (..),
> FrameState,
> FrameReader,
> get,
> put,
> gets,
> startState,
> setPost,
> getField,
> putFields,
> mergeFields,
> putField,
> delField,
>
> 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
>
> data Vars = Vars {
> fields :: Fields
> , validators :: Validators
> , post :: Bool
> , session :: Fields
> , ajax :: Bool
> }
> class (Monad m) => MonadStateGet s m | m -> s where
>
> get :: m s
> instance (Monad m) => MonadStateGet s (StateT s m) where
> get = S.get
> class (Monad m) => MonadStatePut s m | m -> s where
>
> put :: s -> m ()
> instance (Monad m) => MonadStatePut s (StateT s m) where
> put = S.put
>
> gets :: (MonadStateGet s m) => (s -> a)
> -> m a
> 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
>
> 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}
>
> getField :: FrameReader m => FieldName
> -> m (Maybe WrapperType)
> getField fn = do
> fs <- gets fields
> return $ lookup fn fs
>
> delField :: FrameState m
> => FieldName
> -> m ()
> delField fn = do
> fs <- gets fields
> v <- get
> put v {fields=delete fn fs}
>
> putFields :: FrameState m => Fields
> -> m ()
> putFields fs = do
> v <- get
> put v {fields=fs}
>
> mergeFields :: FrameState m => Maybe Fields
> -> m ()
> mergeFields Nothing = return ()
> mergeFields (Just fs') = do
> fs <- gets fields
> putFields $ union fs fs'
>
> putField :: (FrameState m, FrameConfig m, Wrappable a)
> => FieldName
> -> a
> -> m ()
> putField fn f = do
> db <- asks database
> fs <- gets fields
> v <- get
> put v {fields=insert fn (wrap db fn f) fs}
>
> getValidator :: FrameReader m => FieldName
> -> m (Maybe [WrapperType -> Maybe String])
> getValidator fn = do
> vs <- gets validators
> return $ lookup fn vs
>
> putValidators :: FrameState m => Validators
> -> m ()
> putValidators vs = do
> v <- get
> put v {validators=vs}
>
> putValidator :: FrameState m => FieldName
> -> [WrapperType -> Maybe String]
> -> m ()
> putValidator fn ms = do
> vs <- gets validators
> v <- get
> put v {validators=insert fn ms vs}