module Database.HaskellDB.FieldType
(FieldDesc, FieldType(..), toHaskellType, ExprType(..)
, ExprTypes(..), queryFields) where
import Data.Dynamic
import System.Time
import Database.HaskellDB.HDBRec (RecCons(..), Record, RecNil(..), ShowLabels)
import Database.HaskellDB.BoundedString
import Database.HaskellDB.BoundedList (listBound, Size)
import Database.HaskellDB.Query (Expr, Rel, runQueryRel, Query, labels)
type FieldDesc = (FieldType, Bool)
data FieldType =
StringT
| IntT
| IntegerT
| DoubleT
| BoolT
| CalendarTimeT
| BStrT Int
deriving (Eq,Ord,Show,Read)
class ExprType e where
fromHaskellType :: e -> FieldDesc
class ExprTypes r where
fromHaskellTypes :: r -> [FieldDesc]
toHaskellType :: FieldType -> String
toHaskellType StringT = "String"
toHaskellType IntT = "Int"
toHaskellType IntegerT = "Integer"
toHaskellType DoubleT = "Double"
toHaskellType BoolT = "Bool"
toHaskellType CalendarTimeT = "CalendarTime"
toHaskellType (BStrT a) = "BStr" ++ show a
queryFields :: (ShowLabels r, ExprTypes r) => Query (Rel r) -> [(String, FieldDesc)]
queryFields def = zip (labels query) types
where
query = unRel . snd . runQueryRel $ def
types = fromHaskellTypes query
unRel :: (Rel r) -> r
unRel r = undefined
instance Typeable CalendarTime where
typeOf _ = mkTyConApp (mkTyCon "System.Time.CalendarTime") []
instance Typeable (BoundedString n) where
typeOf _ = mkTyConApp (mkTyCon "Database.HaskellDB.BoundedString") []
instance (ExprType a) => ExprType (Maybe a) where
fromHaskellType ~(Just e) = ((fst . fromHaskellType $ e), True)
instance (ExprType a) => ExprType (Expr a) where
fromHaskellType e =
let unExpr :: Expr a -> a
unExpr _ = undefined
in fromHaskellType . unExpr $ e
instance (ExprType a) => ExprType (Rel a) where
fromHaskellType e =
let unRel :: Rel a -> a
unRel _ = undefined
in fromHaskellType . unRel $ e
instance ExprType Bool where
fromHaskellType _ = (BoolT, False)
instance ExprType String where
fromHaskellType _ = (StringT, False)
instance ExprType Int where
fromHaskellType _ = (IntT, False)
instance ExprType Integer where
fromHaskellType _ = (IntegerT, False)
instance ExprType Double where
fromHaskellType _ = (DoubleT, False)
instance ExprType CalendarTime where
fromHaskellType _ = (CalendarTimeT, False)
instance (Size n) => ExprType (BoundedString n) where
fromHaskellType b = (BStrT (listBound b), False)
instance ExprTypes RecNil where
fromHaskellTypes _ = []
instance (ExprType e, ExprTypes r) => ExprTypes (RecCons f e r) where
fromHaskellTypes ~f@(RecCons e r) =
let getFieldType :: RecCons f a r -> a
getFieldType = undefined
in (fromHaskellType . getFieldType $ f) : fromHaskellTypes r
instance (ExprTypes r) => ExprTypes (Record r) where
fromHaskellTypes r = fromHaskellTypes (r RecNil)
instance (ExprTypes r) => ExprTypes (Rel r) where
fromHaskellTypes r =
let unRel :: Rel a -> a
unRel _ = undefined
in fromHaskellTypes . unRel $ r