Model.lhs

> -- | High level model helpers
> module Frame.Model (
>   FrameIO,
>   FrameModel,
>   liftIO,
>   module Database.HaskellDB,
>   module Database.HaskellDB.BoundedList,
>   module Database.HaskellDB.BoundedString,
>   fieldName,
>   tableName,
>   (-.-),
>   run,
>   merge,
>   field,
>   posted,
>   wrapStringField,
>   wrapIntField,
>   wrapMaybeIntField,
>   wrapBoolField
> ) where

> import Database.HaskellDB
> import Database.HaskellDB.HDBC.ODBC
> import Database.HaskellDB.DBSpec.PPHelpers
> import Database.HaskellDB.DBSpec.DBSpecToDBDirect
> import Database.HaskellDB.BoundedList
> import Database.HaskellDB.BoundedString
> import Database.HaskellDB.Query (tableName, attributeName)
> import Database.HaskellDB.DBLayout hiding (fieldName)
> import Database.HaskellDB.PrimQuery
> import Database.HaskellDB.Database
> import Control.Monad.Trans

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

> class (MonadIO m) => FrameIO m
> instance (MonadIO m) => FrameIO m
 
> class (FrameConfig m, FrameState m, FrameIO m) => FrameModel m
> instance (FrameConfig m, FrameState m, FrameIO m) => FrameModel m

> withODBC :: MonadIO m => String -> (Database -> m a) -> m a
> withODBC u = (connect driver) [("DSN", u)]

> -- | Convenience function for a stringed representation fo a table and attribute
> ( -.- ) :: Table r  -- ^ Table
>         -> Attr f a -- ^ Attribute
>         -> String   -- ^ ''TableName.attributeName''
> t -.- a = fieldName (tableName t) $ attributeName a

> -- | Convenience function for creating a qualified attribute name
> fieldName :: String -- ^ Table name
>           -> String -- ^ Attribute name
>           -> String -- ^ ''TableName.attributeName''
> fieldName t f = t ++ "." ++ f

> -- | Execute a database function against the DB
> run :: FrameModel m         
>     => (Database -> m a) -- ^ The function that requires a database
>     -> m a               -- ^ The executed result
> run r = do 
>    u <- asks dbURL
>    withODBC u r

> -- | Take the fields updated by some model action and merge them in to the state
> merge :: (FrameModel m) 
>       => m (Maybe Fields)
>       -> m (Maybe Fields)
> merge mr = do
>     mfs <- mr
>     mergeFields mfs
>     return mfs

> field :: (Wrappable a) 
>       => DBInfo 
>       -> FieldName
>       -> a
>       -> (FieldName, WrapperType)
> field d n f = (n, wrap d n f)

> {-| 
>     Should a form have been posted and all of the fields validate, run some
>     computation which maps fields to a model (with an empty return type)
> -} 
> posted :: FrameModel m 
>        => (Fields -> m a) -- ^ The computation to run
>        -> m Bool          -- ^ Did the computation succeed?
> posted f = do
>     db <- asks database
>     p <- gets post
>     fs <- gets fields
>     vs <- gets validators
>     case (p && allValidated vs fs) of
>        True -> do f $ purge db fs
>                   return True
>        False -> return False

> wrapStringField :: Size n => FieldName -> BoundedList Char n -> (FieldName, WrapperType)
> wrapStringField fn b = (fn, WrapString (Just $ listBound b) $ fromBounded b)

> wrapBoolField :: FieldName -> Bool -> (FieldName, WrapperType)
> wrapBoolField fn v = (fn, WrapBool v)

> wrapIntField :: FieldName -> Int -> (FieldName, WrapperType)
> wrapIntField fn v = (fn, WrapInt v)

> wrapMaybeIntField :: FieldName -> Maybe Int -> (FieldName, WrapperType)
> wrapMaybeIntField fn (Just v) = wrapIntField fn v
> wrapMaybeIntField fn Nothing = (fn, WrapEmpty IntT)