module Database.HaskellDB.Database (
(!.)
, Database(..)
, GetRec(..), GetInstances(..)
, GetValue
, query
, insert, delete, update, insertQuery
, tables, describe, transaction
, createDB, createTable, dropDB, dropTable
) where
import Database.HaskellDB.FieldType
import Database.HaskellDB.PrimQuery
import Database.HaskellDB.Optimize (optimize, optimizeCriteria)
import Database.HaskellDB.Query
import Database.HaskellDB.BoundedString
import Database.HaskellDB.BoundedList
import Database.HaskellDB.HDBRec
import System.Time
import Control.Monad
infix 9 !.
(!.) :: Select f r a => r -> f -> a
row !. attr = row ! attr
data Database
= Database
{ dbQuery :: forall er vr. GetRec er vr =>
PrimQuery
-> Rel er
-> IO [Record vr]
, dbInsert :: TableName -> Assoc -> IO ()
, dbInsertQuery :: TableName -> PrimQuery -> IO ()
, dbDelete :: TableName
-> [PrimExpr]
-> IO ()
, dbUpdate :: TableName
-> [PrimExpr]
-> Assoc
-> IO ()
, dbTables :: IO [TableName]
, dbDescribe :: TableName -> IO [(Attribute,FieldDesc)]
, dbTransaction :: forall a. IO a -> IO a
, dbCreateDB :: String -> IO ()
, dbCreateTable :: TableName -> [(Attribute,FieldDesc)] -> IO ()
, dbDropDB :: String -> IO ()
, dbDropTable :: TableName -> IO ()
}
data GetInstances s =
GetInstances {
getString :: s -> String -> IO (Maybe String)
, getInt :: s -> String -> IO (Maybe Int)
, getInteger :: s -> String -> IO (Maybe Integer)
, getDouble :: s -> String -> IO (Maybe Double)
, getBool :: s -> String -> IO (Maybe Bool)
, getCalendarTime :: s -> String -> IO (Maybe CalendarTime)
}
class GetRec er vr | er -> vr, vr -> er where
getRec :: GetInstances s
-> Rel er
-> Scheme
-> s
-> IO (Record vr)
instance GetRec RecNil RecNil where
getRec _ _ _ _ = return emptyRecord
instance (GetValue a, GetRec er vr)
=> GetRec (RecCons f (Expr a) er) (RecCons f a vr) where
getRec _ _ [] _ = fail $ "Wanted non-empty record, but scheme is empty"
getRec vfs c (f:fs) stmt =
do
x <- getValue vfs stmt f
r <- getRec vfs (recTailType c) fs stmt
return (RecCons x . r)
recTailType :: Rel (RecCons f (Expr a) er) -> Rel er
recTailType _ = undefined
class GetValue a where
getValue :: GetInstances s -> s -> String -> IO a
instance GetValue String where getValue = getNonNull
instance GetValue Int where getValue = getNonNull
instance GetValue Integer where getValue = getNonNull
instance GetValue Double where getValue = getNonNull
instance GetValue Bool where getValue = getNonNull
instance GetValue CalendarTime where getValue = getNonNull
instance Size n => GetValue (BoundedString n) where getValue = getNonNull
instance GetValue (Maybe String) where getValue = getString
instance GetValue (Maybe Int) where getValue = getInt
instance GetValue (Maybe Integer) where getValue = getInteger
instance GetValue (Maybe Double) where getValue = getDouble
instance GetValue (Maybe Bool) where getValue = getBool
instance GetValue (Maybe CalendarTime) where getValue = getCalendarTime
instance Size n => GetValue (Maybe (BoundedString n)) where
getValue fs s f = liftM (liftM trunc) (getValue fs s f)
getNonNull :: GetValue (Maybe a) => GetInstances s -> s -> String -> IO a
getNonNull fs s f =
do
m <- getValue fs s f
case m of
Nothing -> fail $ "Got NULL value from non-NULL field " ++ f
Just v -> return v
query :: GetRec er vr => Database -> Query (Rel er) -> IO [Record vr]
query db q = dbQuery db (optimize primQuery) rel
where (primQuery,rel) = runQueryRel q
insertQuery :: ShowRecRow r => Database -> Table r -> Query (Rel r) -> IO ()
insertQuery db (Table name assoc) q
= dbInsertQuery db name (optimize (runQuery q))
insert :: (ToPrimExprs r, ShowRecRow r, InsertRec r er) => Database -> Table er -> Record r -> IO ()
insert db (Table name assoc) newrec
= dbInsert db name (zip (attrs assoc) (exprs newrec))
where
attrs = map (\(attr,AttrExpr name) -> name)
delete :: ShowRecRow r =>
Database
-> Table r
-> (Rel r -> Expr Bool)
-> IO ()
delete db (Table name assoc) criteria = dbDelete db name cs
where
(Expr primExpr) = criteria rel
cs = optimizeCriteria [substAttr assoc primExpr]
rel = Rel 0 (map fst assoc)
update :: (ShowLabels s, ToPrimExprs s) =>
Database
-> Table r
-> (Rel r -> Expr Bool)
-> (Rel r -> Record s)
-> IO ()
update db (Table name assoc) criteria assignFun = dbUpdate db name cs newassoc
where
(Expr primExpr)= criteria rel
cs = optimizeCriteria [substAttr assoc primExpr]
newassoc = zip (map subst (labels assigns))
(exprs assigns)
subst label = case (lookup label assoc) of
(Just (AttrExpr name)) -> name
(Nothing) -> error ("Database.update: attribute '"
++ label ++ "' is not in database '" ++ name ++ "'")
assigns = assignFun rel
rel = Rel 0 (map fst assoc)
tables :: Database
-> IO [TableName]
tables = dbTables
describe :: Database
-> TableName
-> IO [(Attribute,FieldDesc)]
describe = dbDescribe
transaction :: Database
-> IO a
-> IO a
transaction = dbTransaction
createDB :: Database
-> String
-> IO ()
createDB = dbCreateDB
createTable :: Database
-> TableName
-> [(Attribute,FieldDesc)]
-> IO ()
createTable = dbCreateTable
dropDB :: Database
-> String
-> IO ()
dropDB = dbDropDB
dropTable :: Database
-> TableName
-> IO ()
dropTable = dbDropTable