>
> 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
>
> type FieldName = String
>
> type Fields = Map FieldName WrapperType
>
> showField :: FieldName
> -> Fields
> -> String
> 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 :: DBInfo
> -> Fields
> -> 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
>
> lookupFD :: DBInfo
> -> FieldName
> -> Maybe FieldDesc
> 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
>
> data WrapperType
> = WrapString (Maybe Int) String
> | WrapInt Int
> | WrapBool Bool
> | WrapError FieldType String
> | WrapEmpty FieldType
> 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
>
> wrap :: DBInfo
> -> FieldName
> -> a
> -> WrapperType
>
>
> unwrap :: WrapperType
> -> a
> 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
>
> wrapInt :: String
> -> WrapperType
> 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
>
> wrapBool :: String
> -> WrapperType
> 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
>
> wrapError :: WrapperType
> -> String
> 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
>
> maybeUnwrap :: Maybe WrapperType
> -> WrapperType
> maybeUnwrap (Just t) = t
> maybeUnwrap Nothing = WrapEmpty $ BStrT 0
>
> fromList' :: DBInfo
> -> [(FieldName, String)]
> -> Map FieldName WrapperType
> 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