> {-|
>     Defines a homogenous collection of field types to interface typeless
>     HTTP and HTML with the application and with HaskellDB
> -}
> module Frame.Types (
>    module Database.HaskellDB.FieldType,
>    FieldName,
>    WrapperType (..),
>    Fields,
>    showField,
>    purge,
>    Wrappable (..),
>    wrapInt,
>    wrapBool,
>    wrapError,
>    isMandatory,
>    maybeUnwrap,
>    fromList',
>    unwrapField
> ) where

> import Prelude hiding (lookup)
> import Data.Map hiding (map)
> import Database.HaskellDB.BoundedList
> import Database.HaskellDB.DBLayout
> import Database.HaskellDB.FieldType
> import Data.Binary
> import Data.Maybe
> import Control.Monad

> import Frame.Utilities

> -- | Label for a specific field
> type FieldName = String

> -- | Collection of heterogenous fields associated by 'FieldName'
> type Fields = Map FieldName WrapperType

> -- | Casts the 'FieldName' in fields to string
> showField :: FieldName -- ^ Field name to look up
>           -> Fields    -- ^ Fields to look in
>           -> String    -- ^ String representation of field to return
> showField fn fs = case lookup fn fs of
>                      Nothing -> ""
>                      Just w -> show w

> purge' :: DBInfo
>        -> FieldName 
>        -> WrapperType
>        -> Bool
> purge' _ fn (WrapEmpty (BStrT _)) = True
> purge' db fn (WrapEmpty _)         = case isMandatory db fn of
>                                            (Just b) -> not b
>                                            Nothing  -> True
> purge' db _ _                      = True

> -- | Purge non mandatory empty fields 
> purge :: DBInfo
>       -> Fields -- ^ Fields to purge
>       -> Fields -- ^ Purged fields
> purge db = filterWithKey (purge' db)

> lookupFD' :: DBInfo -> String -> String -> Maybe FieldDesc
> lookupFD' DBInfo {tbls = []} t _ = Nothing
> lookupFD' d@DBInfo {tbls = (TInfo {tname = n, cols = cs}:ts)} t c = if n == t then lookupFD'' cs c else lookupFD' d {tbls = ts} t c

> lookupFD'' :: [CInfo]  
>            -> String    
>            -> Maybe FieldDesc 
> lookupFD'' [] c = Nothing
> lookupFD'' (CInfo {cname=n, descr=d}:cs) c = if n == c then Just d else lookupFD'' cs c

> -- | Find a FieldDesc(ription) of a particular FieldName
> lookupFD :: DBInfo          -- ^ Database description being searched
>          -> FieldName       -- ^ Field name being looked up
>          -> Maybe FieldDesc -- ^ Description of field found
> lookupFD db fn = let (l, fns) = explodeFieldName fn in
>                      if l /= 2 then Nothing else 
>                          lookupFD' db (head fns) (head $ tail fns)

> lookupT :: DBInfo
>         -> FieldName
>         -> Maybe FieldType
> lookupT db fn = liftM fst $ lookupFD db fn

> lookupM :: DBInfo
>         -> FieldName
>         -> Maybe Bool
> lookupM db fn = liftM snd $ lookupFD db fn

> -- | Heterogeneous type wrapper
> data WrapperType
>      = WrapString (Maybe Int) String -- ^ String wrapper
>      | WrapInt Int                   -- ^ Int wrappr
>      | WrapBool Bool                 -- ^ Bool wrapper
>      | WrapError FieldType String    -- ^ Type error (specific case of error)
>      | WrapEmpty FieldType           -- ^ Empty type

> instance Show WrapperType where
>   show (WrapString _ s) = s
>   show (WrapInt i) = show i
>   show (WrapBool b) = show b
>   show (WrapError _ s) = s
>   show (WrapEmpty _) = ""

> isMandatory :: DBInfo -> FieldName -> Maybe Bool
> isMandatory = lookupM

> class Wrappable a where
>  -- | Function to wrap a value associated with a given 'FieldName'
>  wrap :: DBInfo      -- ^ The database to check for the type
>       -> FieldName   -- ^ Field name that represents this value
>       -> a           -- ^ The value in question
>       -> WrapperType -- ^ The wrapped value
>
>  -- | Function to unwrap a 'WrapperType' to its original type
>  unwrap :: WrapperType -- ^ The wrapped type
>         -> a           -- ^ The originally typed value

> instance Wrappable Int where
>   wrap db fn i = wrap db fn (show i) 
>   unwrap (WrapInt i) = i
>   unwrap (WrapEmpty _) = 0
>   unwrap (WrapString _ s) = read s
>   unwrap (WrapBool False) = 0
>   unwrap (WrapBool True) = 1
>   unwrap _ = error "Not an Int"

> instance Wrappable WrapperType where
>   wrap _ _ w = w
>   unwrap w = w

> instance Wrappable [Char] where
>   wrap db fn s = let t = lookupT db fn in
>                 wrap' s t
>   unwrap (WrapString _ s) = s
>   unwrap (WrapEmpty _) = ""
>   unwrap (WrapInt i) = show i
>   unwrap (WrapBool b) = show b
>   unwrap _ = "Error in unwrapping potential String"

> instance Wrappable Bool where
>   wrap db fn b = wrap db fn (show b)
>   unwrap (WrapBool b) = b
>   unwrap (WrapEmpty b) = False
>   unwrap (WrapString _ "False") = False
>   unwrap (WrapString _ "True") = True
>   unwrap (WrapInt 0) = False
>   unwrap (WrapInt 1) = True
>   unwrap _ = error "Not an Bool"

> instance Size n => Wrappable (BoundedList Char n) where
>   wrap db fn bs = wrap db fn $ fromBounded bs
>   unwrap w = trunc $ unwrap w

> instance Show a => Wrappable (Maybe a) where
>   wrap db fn (Just a) = wrap db fn $ show a 
>   wrap _ _ Nothing = WrapEmpty IntT
>   unwrap _ = Nothing

> -- | Wrap a 'String' representation of an 'Int'
> wrapInt :: String      -- 'String' to be wrapped
>         -> WrapperType -- The wrapped 'Int' (unless empty/error)
> wrapInt v = wrapInt' v $ reads v

> wrapInt' :: String
>          -> [(Int, String)]
>          -> WrapperType 
> wrapInt' _ ((v,""):ts) = WrapInt v
> wrapInt' "" _          = WrapEmpty IntT
> wrapInt' v ((_,_):ts)  = WrapError IntT v
> wrapInt' v []          = WrapError IntT v

> -- | Wrap a 'String' representation of a 'Bool'
> wrapBool :: String      -- 'String' to be wrapped
>          -> WrapperType -- The wrapped 'Bool' (unless empty/error)
> wrapBool v = wrapBool' v $ reads v 

> wrapBool' :: String
>           -> [(Bool, String)]
>           -> WrapperType 
> wrapBool' _ ((v,""):ts) = WrapBool v
> wrapBool' "" _          = WrapEmpty BoolT
> wrapBool' v ((_,_):ts)  = WrapError BoolT v
> wrapBool' v []          = WrapError BoolT v

> -- | Returns an error message if there has been a wrapping error
> wrapError :: WrapperType -- ^ The wrapped type to check
>           -> String      -- ^ Error message
> wrapError (WrapError IntT _)  = "Needs to be a number"
> wrapError (WrapError BoolT _) = "Needs to be a boolean" 
> wrapError (WrapError (BStrT _) _) = "Could not wrap" 

> wrap' :: String
>       -> Maybe FieldType
>       -> WrapperType
> wrap' v (Just IntT)      = wrapInt v
> wrap' v (Just (BStrT l)) = WrapString (Just l) v
> wrap' v (Just BoolT)     = wrapBool v
> wrap' "" (Just t)        = WrapEmpty t
> wrap' "" Nothing         = WrapEmpty $ BStrT 0
> wrap' v (Just t)         = WrapError t v
> wrap' v Nothing          = WrapError (BStrT $ length v) v

> -- | A potential 'WrapperType' is 'WrapEmpty' if 'Nothing'
> maybeUnwrap :: Maybe WrapperType -- ^ The potential wrapped type
>             -> WrapperType       -- ^ Definitely a wrapped type (though perhaps an empty one)
> maybeUnwrap (Just t) = t
> maybeUnwrap Nothing = WrapEmpty $ BStrT 0

> -- | Special version of 'Data.Map.fromList' that also wraps fields as it goes
> fromList' :: DBInfo                    -- ^ Database to use for wrapping info
>           -> [(FieldName, String)]     -- ^ List of pairs associating a field name to some 'String' representation of a value 
>           -> Map FieldName WrapperType -- ^ The map associating field names to wrapped types
> fromList' db is = fromList $ map (\x -> let fx = fst x in (fx, wrap db fx $ snd x)) is

> unwrapField :: Wrappable a => FieldName -> Fields -> Maybe a
> unwrapField fn fs = appMaybe unwrap $ lookup fn fs 

> instance Binary FieldType where
>   put StringT       = putWord8 0
>   put IntT          = putWord8 1
>   put IntegerT      = putWord8 2
>   put DoubleT       = putWord8 3
>   put BoolT         = putWord8 4
>   put CalendarTimeT = putWord8 5
>   put (BStrT i)     = do
>     putWord8 6
>     put i
>   get = do
>     tag <- getWord8
>     case tag of
>        0 -> return StringT
>        1 -> return IntT
>        2 -> return IntegerT
>        3 -> return DoubleT
>        4 -> return BoolT
>        5 -> return CalendarTimeT
>        6 -> do
>          i <- get
>          return $ BStrT i

> instance Binary WrapperType where
>  put (WrapString mi s) = do 
>     putWord8 0 
>     put mi
>     put s
>  put (WrapInt i) = do
>     putWord8 1
>     put i
>  put (WrapBool b) = do
>     putWord8 2
>     put b
>  put (WrapError t s) = do
>     putWord8 3
>     put t
>     put s
>  put (WrapEmpty t) = do
>     putWord8 4
>     put t
>  get = do
>     tag <- getWord8
>     case tag of
>        0 -> do
>          mi <- get
>          s <- get
>          return $ WrapString mi s
>        1 -> do
>          i <- get
>          return $ WrapInt i
>        2 -> do
>          b <- get
>          return $ WrapBool b
>        3 -> do
>          t <- get
>          s <- get
>          return $ WrapError t s
>        4 -> do
>          t <- get
>          return $ WrapEmpty t