diff --git a/schema-th/HDBC-schema-th.cabal b/schema-th/HDBC-schema-th.cabal index 26d0e2a0..7592b2f1 100644 --- a/schema-th/HDBC-schema-th.cabal +++ b/schema-th/HDBC-schema-th.cabal @@ -19,10 +19,11 @@ library default-language: Haskell2010 other-modules: Language.SQL.SqlWord - exposed-modules: Database.HDBC.Record.Persistable - Database.HDBC.Record.KeyConstraint - Database.HDBC.Record.FromSql - Database.HDBC.Record.ToSql + exposed-modules: Database.Record.Persistable + Database.Record.KeyConstraint + Database.Record.FromSql + Database.Record.ToSql + Database.HDBC.Record.Persistable Database.HDBC.Record.Query Database.HDBC.TH Database.HDBC.SqlValueExtra diff --git a/schema-th/src/Database/HDBC/Record/FromSql.hs b/schema-th/src/Database/HDBC/Record/FromSql.hs deleted file mode 100644 index 64f4e1ae..00000000 --- a/schema-th/src/Database/HDBC/Record/FromSql.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Database.HDBC.Record.FromSql --- Copyright : 2013 Kei Hibino --- License : BSD3 --- --- Maintainer : ex8k.hibino@gmail.com --- Stability : experimental --- Portability : unknown -module Database.HDBC.Record.FromSql ( - RecordFromSql, runTakeRecord, runToRecord, - createRecordFromSql, - - recordDeSerializer, - - (<&>), - - outer, - - FromSql (recordFromSql), recordFromSql', - takeRecord, toRecord, - ) where - -import Database.HDBC.Record.Persistable - (PersistableRecord, Singleton, Persistable(persistable)) -import Database.HDBC.Record.KeyConstraint - (HasKeyConstraint(constraintKey), KeyConstraint, NotNull, index) -import qualified Database.HDBC.Record.Persistable as Persistable - -import Database.HDBC (SqlValue(SqlNull)) -import Control.Monad (liftM, ap) -import Control.Applicative ((<$>), Applicative(pure, (<*>))) - - -newtype RecordFromSql a = - RecordFromSql - { runTakeRecord :: [SqlValue] -> (a, [SqlValue]) } - -createRecordFromSql :: ([SqlValue] -> (a, [SqlValue])) -> RecordFromSql a -createRecordFromSql = RecordFromSql - -recordDeSerializer :: PersistableRecord a -> RecordFromSql a -recordDeSerializer = createRecordFromSql . Persistable.takeRecord - -runToRecord :: RecordFromSql a -> [SqlValue] -> a -runToRecord r = fst . runTakeRecord r - - -instance Monad RecordFromSql where - return a = createRecordFromSql ((,) a) - ma >>= fmb = - createRecordFromSql (\vals -> - let (a, vals') = runTakeRecord ma vals - in runTakeRecord (fmb a) vals') - -instance Functor RecordFromSql where - fmap = liftM - -instance Applicative RecordFromSql where - pure = return - (<*>) = ap - -(<&>) :: RecordFromSql a -> RecordFromSql b -> RecordFromSql (a, b) -a <&> b = (,) <$> a <*> b - -infixl 4 <&> - - -outer :: RecordFromSql a -> KeyConstraint NotNull a -> RecordFromSql (Maybe a) -outer rec pkey = createRecordFromSql mayToRec where - mayToRec vals - | vals !! index pkey /= SqlNull = (Just a, vals') - | otherwise = (Nothing, vals') where - (a, vals') = runTakeRecord rec vals - - -class FromSql a where - recordFromSql :: RecordFromSql a - -recordFromSql' :: Persistable a => RecordFromSql a -recordFromSql' = recordDeSerializer persistable - -instance Persistable (Singleton a) => FromSql (Singleton a) where - recordFromSql = recordFromSql' - -instance (FromSql a, FromSql b) => FromSql (a, b) where - recordFromSql = recordFromSql <&> recordFromSql - -instance (HasKeyConstraint NotNull a, FromSql a) => FromSql (Maybe a) where - recordFromSql = outer recordFromSql $ constraintKey - -takeRecord :: FromSql a => [SqlValue] -> (a, [SqlValue]) -takeRecord = runTakeRecord recordFromSql - -toRecord :: FromSql a => [SqlValue] -> a -toRecord = fst . takeRecord diff --git a/schema-th/src/Database/HDBC/Record/Persistable.hs b/schema-th/src/Database/HDBC/Record/Persistable.hs deleted file mode 100644 index b2fe514e..00000000 --- a/schema-th/src/Database/HDBC/Record/Persistable.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{--# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Database.HDBC.Record.Persistable --- Copyright : 2013 Kei Hibino --- License : BSD3 --- --- Maintainer : ex8k.hibino@gmail.com --- Stability : experimental --- Portability : unknown -module Database.HDBC.Record.Persistable ( - PersistableRecord, persistableRecord, - toRecord, fromRecord, width, - Singleton(runSingleton), singleton, - - persistableSingleton, - - Persistable (..), - - takeRecord - ) where - -import Data.Convertible (Convertible) -import Database.HDBC (SqlValue, fromSql, toSql) - - -data PersistableRecord a = - PersistableRecord - { toRecord :: [SqlValue] -> a - , fromRecord :: a -> [SqlValue] - , width :: !Int - } - -newtype Singleton a = Singleton { runSingleton :: a } - -singleton :: a -> Singleton a -singleton = Singleton - -persistableRecord :: ([SqlValue] -> a) -> (a -> [SqlValue]) -> Int -> PersistableRecord a -persistableRecord = PersistableRecord - -persistableSingleton :: (Convertible SqlValue a, Convertible a SqlValue) - => PersistableRecord (Singleton a) -persistableSingleton = persistableRecord (Singleton . fromSql . head) ((:[]) . toSql . runSingleton) 1 - -class Persistable a where - persistable :: PersistableRecord a - -instance (Convertible SqlValue a, Convertible a SqlValue) - => Persistable (Singleton a) where - persistable = persistableSingleton - -takeRecord :: PersistableRecord a -> [SqlValue] -> (a, [SqlValue]) -takeRecord rec vals = (toRecord rec va, vr) where - (va, vr) = splitAt (width rec) vals diff --git a/schema-th/src/Database/HDBC/Record/Query.hs b/schema-th/src/Database/HDBC/Record/Query.hs index 9a7445e7..b782aafd 100644 --- a/schema-th/src/Database/HDBC/Record/Query.hs +++ b/schema-th/src/Database/HDBC/Record/Query.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.HDBC.Record.Query -- Copyright : 2013 Kei Hibino @@ -27,8 +28,8 @@ import Data.Maybe (listToMaybe) import Database.HDBC (IConnection, Statement, SqlValue) import qualified Database.HDBC as HDBC -import Database.HDBC.Record.ToSql (RecordToSql(fromRecord), ToSql(recordToSql)) -import Database.HDBC.Record.FromSql (RecordFromSql, runToRecord, FromSql(recordFromSql)) +import Database.Record.ToSql (RecordToSql(fromRecord), ToSql(recordToSql)) +import Database.Record.FromSql (RecordFromSql, runToRecord, FromSql(recordFromSql)) newtype Query p a = Query { untypeQuery :: String } @@ -55,10 +56,10 @@ data ExecutedStatement a = prepare :: IConnection conn => conn -> Query p a -> IO (PreparedQuery p a) prepare conn = fmap PreparedQuery . HDBC.prepare conn . untypeQuery -bindTo' :: RecordToSql p -> p -> PreparedQuery p a -> BoundStatement a +bindTo' :: RecordToSql SqlValue p -> p -> PreparedQuery p a -> BoundStatement a bindTo' toSql p q = BoundStatement { bound = prepared q, params = fromRecord toSql p } -bindTo :: ToSql p => p -> PreparedQuery p a -> BoundStatement a +bindTo :: ToSql SqlValue p => p -> PreparedQuery p a -> BoundStatement a bindTo = bindTo' recordToSql execute :: BoundStatement a -> IO (ExecutedStatement a) @@ -67,18 +68,21 @@ execute bs = do n <- HDBC.execute stmt (params bs) return $ ExecutedStatement stmt n -fetchRecordsExplicit :: (Statement -> IO [[SqlValue]]) -> RecordFromSql a -> ExecutedStatement a -> IO [a] +fetchRecordsExplicit :: (Statement -> IO [[SqlValue]]) + -> RecordFromSql SqlValue a + -> ExecutedStatement a + -> IO [a] fetchRecordsExplicit fetch fromSql es = do rows <- fetch (executed es) return $ map (runToRecord fromSql) rows -fetchAll :: FromSql a => ExecutedStatement a -> IO [a] +fetchAll :: FromSql SqlValue a => ExecutedStatement a -> IO [a] fetchAll = fetchRecordsExplicit HDBC.fetchAllRows recordFromSql -fetchAll' :: FromSql a => ExecutedStatement a -> IO [a] +fetchAll' :: FromSql SqlValue a => ExecutedStatement a -> IO [a] fetchAll' = fetchRecordsExplicit HDBC.fetchAllRows' recordFromSql -fetchUnique :: FromSql a => ExecutedStatement a -> IO (Maybe a) +fetchUnique :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a) fetchUnique = fmap listToMaybe . fetchAll listToUnique :: [a] -> IO (Maybe a) @@ -87,24 +91,38 @@ listToUnique = d where d [r] = return $ Just r d (_:_:_) = ioError . userError $ "listToUnique': more than one record found." -fetchUnique' :: FromSql a => ExecutedStatement a -> IO (Maybe a) +fetchUnique' :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a) fetchUnique' es = do fetchAll es >>= listToUnique -runStatement :: FromSql a => BoundStatement a -> IO [a] +runStatement :: FromSql SqlValue a => BoundStatement a -> IO [a] runStatement = (>>= fetchAll) . execute -runStatement' :: FromSql a => BoundStatement a -> IO [a] +runStatement' :: FromSql SqlValue a => BoundStatement a -> IO [a] runStatement' = (>>= fetchAll') . execute -runPreparedQuery :: (ToSql p, FromSql a) => p -> PreparedQuery p a -> IO [a] +runPreparedQuery :: (ToSql SqlValue p, FromSql SqlValue a) + => p + -> PreparedQuery p a + -> IO [a] runPreparedQuery p = runStatement . (p `bindTo`) -runPreparedQuery' :: (ToSql p, FromSql a) => p -> PreparedQuery p a -> IO [a] +runPreparedQuery' :: (ToSql SqlValue p, FromSql SqlValue a) + => p + -> PreparedQuery p a + -> IO [a] runPreparedQuery' p = runStatement' . (p `bindTo`) -runQuery :: (IConnection conn, ToSql p, FromSql a) => conn -> p -> Query p a -> IO [a] +runQuery :: (IConnection conn, ToSql SqlValue p, FromSql SqlValue a) + => conn + -> p + -> Query p a + -> IO [a] runQuery conn p = (>>= runPreparedQuery p) . prepare conn -runQuery' :: (IConnection conn, ToSql p, FromSql a) => conn -> p -> Query p a -> IO [a] +runQuery' :: (IConnection conn, ToSql SqlValue p, FromSql SqlValue a) + => conn + -> p + -> Query p a + -> IO [a] runQuery' conn p = (>>= runPreparedQuery' p) . prepare conn diff --git a/schema-th/src/Database/HDBC/Schema/IBMDB2.hs b/schema-th/src/Database/HDBC/Schema/IBMDB2.hs index 07d59b40..f14a1240 100644 --- a/schema-th/src/Database/HDBC/Schema/IBMDB2.hs +++ b/schema-th/src/Database/HDBC/Schema/IBMDB2.hs @@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.IBMDB2 @@ -28,7 +29,7 @@ import Database.HDBC (IConnection) import Database.HDBC.SqlValueExtra () import Database.HDBC.TH (derivingShow) import qualified Database.HDBC.TH as Base -import Database.HDBC.Record.Persistable (Singleton, singleton, runSingleton) +import Database.Record.Persistable (Singleton, singleton, runSingleton) import Database.HDBC.Record.Query (Query(..), typedQuery, runQuery', listToUnique) import Language.SQL.SqlWord (SqlWord(..)) import qualified Language.SQL.SqlWord as SQL diff --git a/schema-th/src/Database/HDBC/Schema/PgCatalog/PgAttribute.hs b/schema-th/src/Database/HDBC/Schema/PgCatalog/PgAttribute.hs index 9c5a9699..61de0293 100644 --- a/schema-th/src/Database/HDBC/Schema/PgCatalog/PgAttribute.hs +++ b/schema-th/src/Database/HDBC/Schema/PgCatalog/PgAttribute.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.PgCatalog.PgAttribute diff --git a/schema-th/src/Database/HDBC/Schema/PgCatalog/PgType.hs b/schema-th/src/Database/HDBC/Schema/PgCatalog/PgType.hs index 9326d5c2..cedeb97a 100644 --- a/schema-th/src/Database/HDBC/Schema/PgCatalog/PgType.hs +++ b/schema-th/src/Database/HDBC/Schema/PgCatalog/PgType.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.PgCatalog.PgType diff --git a/schema-th/src/Database/HDBC/Schema/PostgreSQL.hs b/schema-th/src/Database/HDBC/Schema/PostgreSQL.hs index f8ff2a18..296dbd61 100644 --- a/schema-th/src/Database/HDBC/Schema/PostgreSQL.hs +++ b/schema-th/src/Database/HDBC/Schema/PostgreSQL.hs @@ -27,7 +27,7 @@ import Database.HDBC (IConnection) import Database.HDBC.SqlValueExtra () import qualified Database.HDBC.TH as Base -import Database.HDBC.Record.Persistable (Singleton, singleton, runSingleton) +import Database.Record.Persistable (Singleton, singleton, runSingleton) import Database.HDBC.Record.Query (Query(..), typedQuery, runQuery', listToUnique) import Database.HDBC.Schema.PgCatalog.PgAttribute (PgAttribute, tableOfPgAttribute, fieldsOfPgAttribute) diff --git a/schema-th/src/Database/HDBC/TH.hs b/schema-th/src/Database/HDBC/TH.hs index 3ac63dab..02a8b35f 100644 --- a/schema-th/src/Database/HDBC/TH.hs +++ b/schema-th/src/Database/HDBC/TH.hs @@ -70,12 +70,13 @@ import qualified Language.Haskell.TH.PprLib as TH import qualified Language.Haskell.TH.Syntax as TH import Database.HDBC.Session (withConnectionIO) -import Database.HDBC.Record.Persistable +import Database.Record.Persistable (persistableRecord, Persistable, persistable, Singleton) -import Database.HDBC.Record.KeyConstraint +import Database.Record.KeyConstraint (HasKeyConstraint(constraintKey), specifyKeyConstraint, Primary, NotNull) -import Database.HDBC.Record.FromSql (FromSql(recordFromSql), recordFromSql') -import Database.HDBC.Record.ToSql (ToSql(recordToSql), recordToSql') +import Database.Record.FromSql (FromSql(recordFromSql), recordFromSql') +import Database.Record.ToSql (ToSql(recordToSql), recordToSql') +import Database.HDBC.Record.Persistable () import Database.HDBC.Record.Query (Query, typedQuery) import Language.SQL.SqlWord (SqlWord(..), (<=>)) import qualified Language.SQL.SqlWord as SQL @@ -222,16 +223,16 @@ defineTableInfo tableVar' table fieldsVar' fields widthVar' width = do definePersistableInstance :: VarName -> TypeQ -> VarName -> VarName -> Int -> Q [Dec] definePersistableInstance widthVar' typeCon consFunName' decompFunName' width = do - [d| instance Persistable $typeCon where + [d| instance Persistable SqlValue $typeCon where persistable = persistableRecord $(varE $ varName consFunName') $(varE $ varName decompFunName') $(varE $ varName widthVar') - instance FromSql $typeCon where + instance FromSql SqlValue $typeCon where recordFromSql = recordFromSql' - instance ToSql $typeCon where + instance ToSql SqlValue $typeCon where recordToSql = recordToSql' |] diff --git a/schema-th/src/Database/Record/FromSql.hs b/schema-th/src/Database/Record/FromSql.hs new file mode 100644 index 00000000..a5a957b9 --- /dev/null +++ b/schema-th/src/Database/Record/FromSql.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Database.Record.FromSql +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +module Database.Record.FromSql ( + RecordFromSql, runTakeRecord, runToRecord, + createRecordFromSql, + + recordDeSerializer, + + (<&>), + + outer, + + FromSql (recordFromSql), recordFromSql', + takeRecord, toRecord, + ) where + +import Database.Record.Persistable + (PersistableRecord, Singleton, + Persistable(persistable), PersistableNull) +import qualified Database.Record.Persistable as Persistable +import Database.Record.KeyConstraint + (HasKeyConstraint(constraintKey), KeyConstraint, NotNull, index) + +import Control.Monad (liftM, ap) +import Control.Applicative ((<$>), Applicative(pure, (<*>))) + + +newtype RecordFromSql q a = + RecordFromSql + { runTakeRecord :: [q] -> (a, [q]) } + +createRecordFromSql :: ([q] -> (a, [q])) -> RecordFromSql q a +createRecordFromSql = RecordFromSql + +recordDeSerializer :: PersistableRecord q a -> RecordFromSql q a +recordDeSerializer = createRecordFromSql . Persistable.takeRecord + +runToRecord :: RecordFromSql q a -> [q] -> a +runToRecord r = fst . runTakeRecord r + +instance Monad (RecordFromSql q) where + return a = createRecordFromSql ((,) a) + ma >>= fmb = + createRecordFromSql + (\vals -> let (a, vals') = runTakeRecord ma vals + in runTakeRecord (fmb a) vals') + +instance Functor (RecordFromSql q) where + fmap = liftM + +instance Applicative (RecordFromSql q) where + pure = return + (<*>) = ap + +(<&>) :: RecordFromSql q a -> RecordFromSql q b -> RecordFromSql q (a, b) +a <&> b = (,) <$> a <*> b + +infixl 4 <&> + + +outer :: PersistableNull q + => RecordFromSql q a + -> KeyConstraint NotNull a + -> RecordFromSql q (Maybe a) +outer rec pkey = createRecordFromSql mayToRec where + mayToRec vals + | vals !! index pkey /= Persistable.sqlNullValue = (Just a, vals') + | otherwise = (Nothing, vals') where + (a, vals') = runTakeRecord rec vals + + +class FromSql q a where + recordFromSql :: RecordFromSql q a + +recordFromSql' :: Persistable q a => RecordFromSql q a +recordFromSql' = recordDeSerializer persistable + +instance Persistable q (Singleton a) => FromSql q (Singleton a) where + recordFromSql = recordFromSql' + +instance (FromSql q a, FromSql q b) => FromSql q (a, b) where + recordFromSql = recordFromSql <&> recordFromSql + +instance (HasKeyConstraint NotNull a, FromSql q a, PersistableNull q) + => FromSql q (Maybe a) where + recordFromSql = outer recordFromSql $ constraintKey + +takeRecord :: FromSql q a => [q] -> (a, [q]) +takeRecord = runTakeRecord recordFromSql + +toRecord :: FromSql q a => [q] -> a +toRecord = fst . takeRecord diff --git a/schema-th/src/Database/HDBC/Record/KeyConstraint.hs b/schema-th/src/Database/Record/KeyConstraint.hs similarity index 96% rename from schema-th/src/Database/HDBC/Record/KeyConstraint.hs rename to schema-th/src/Database/Record/KeyConstraint.hs index 8cbeda29..f41d1fba 100644 --- a/schema-th/src/Database/HDBC/Record/KeyConstraint.hs +++ b/schema-th/src/Database/Record/KeyConstraint.hs @@ -10,7 +10,7 @@ -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -module Database.HDBC.Record.KeyConstraint ( +module Database.Record.KeyConstraint ( KeyConstraint (index), specifyKeyConstraint, Unique, UniqueConstraint, diff --git a/schema-th/src/Database/Record/Persistable.hs b/schema-th/src/Database/Record/Persistable.hs new file mode 100644 index 00000000..6ef70caf --- /dev/null +++ b/schema-th/src/Database/Record/Persistable.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Database.Record.Persistable +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +module Database.Record.Persistable ( + Singleton(runSingleton), singleton, + + PersistableNullValue(runPersistableNullValue), persistableNullValue, + PersistableValue, persistableValue, + PersistableRecord, persistableRecord, + toRecord, fromRecord, width, + + persistableRecordFromValue, + + PersistableNull(..), sqlNullValue, + + Persistable (..), takeRecord + ) where + +newtype Singleton a = Singleton { runSingleton :: a } + +newtype PersistableNullValue q = + PersistableNullValue + { runPersistableNullValue :: q } + +data PersistableValue q a = + PersistableValue + { toValue :: q -> a + , fromValue :: a -> q + } + +data PersistableRecord q a = + PersistableRecord + { toRecord :: [q] -> a + , fromRecord :: a -> [q] + , width :: !Int + } + +singleton :: a -> Singleton a +singleton = Singleton + +persistableNullValue :: q -> PersistableNullValue q +persistableNullValue = PersistableNullValue + +persistableValue :: (q -> a) -> (a -> q) -> PersistableValue q a +persistableValue = PersistableValue + +persistableRecord :: ([q] -> a) -> (a -> [q]) -> Int -> PersistableRecord q a +persistableRecord = PersistableRecord + +persistableRecordFromValue :: PersistableValue q a -> PersistableRecord q a +persistableRecordFromValue pv = + persistableRecord(toValue pv . head) ((:[]) . fromValue pv) 1 + +class Eq q => PersistableNull q where + persistableNull :: PersistableNullValue q + +sqlNullValue :: PersistableNull q => q +sqlNullValue = runPersistableNullValue persistableNull + +class Persistable q a where + persistable :: PersistableRecord q a + +takeRecord :: PersistableRecord q a -> [q] -> (a, [q]) +takeRecord rec vals = (toRecord rec va, vr) where + (va, vr) = splitAt (width rec) vals diff --git a/schema-th/src/Database/HDBC/Record/ToSql.hs b/schema-th/src/Database/Record/ToSql.hs similarity index 55% rename from schema-th/src/Database/HDBC/Record/ToSql.hs rename to schema-th/src/Database/Record/ToSql.hs index d97babce..c14888ad 100644 --- a/schema-th/src/Database/HDBC/Record/ToSql.hs +++ b/schema-th/src/Database/Record/ToSql.hs @@ -1,15 +1,17 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} -- | --- Module : Database.HDBC.Record.ToSql +-- Module : Database.Record.ToSql -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -module Database.HDBC.Record.ToSql ( +module Database.Record.ToSql ( RecordToSql, fromRecord, createRecordToSql, @@ -21,49 +23,47 @@ module Database.HDBC.Record.ToSql ( updateValuesByPrimary ) where -import Database.HDBC.Record.Persistable +import Database.Record.Persistable (PersistableRecord, Persistable(persistable), Singleton) -import Database.HDBC.Record.KeyConstraint +import Database.Record.KeyConstraint (HasKeyConstraint(constraintKey), KeyConstraint, Primary, Unique, unique, index) -import qualified Database.HDBC.Record.Persistable as Persistable - -import Database.HDBC (SqlValue) +import qualified Database.Record.Persistable as Persistable -data RecordToSql a = +data RecordToSql q a = RecordToSql - { fromRecord :: a -> [SqlValue] } + { fromRecord :: a -> [q] } -createRecordToSql :: (a -> [SqlValue]) -> RecordToSql a +createRecordToSql :: (a -> [q]) -> RecordToSql q a createRecordToSql = RecordToSql -class ToSql a where - recordToSql :: RecordToSql a +class ToSql q a where + recordToSql :: RecordToSql q a -recordSerializer :: PersistableRecord a -> RecordToSql a +recordSerializer :: PersistableRecord q a -> RecordToSql q a recordSerializer = createRecordToSql . Persistable.fromRecord -instance Persistable (Singleton a) => ToSql (Singleton a) where +instance Persistable q (Singleton a) => ToSql q (Singleton a) where recordToSql = recordSerializer persistable -(<&>) :: RecordToSql a -> RecordToSql b -> RecordToSql (a, b) +(<&>) :: RecordToSql q a -> RecordToSql q b -> RecordToSql q (a, b) ra <&> rb = RecordToSql (\(a, b) -> fromRecord ra a ++ fromRecord rb b) -instance (ToSql a, ToSql b) => ToSql (a, b) where +instance (ToSql q a, ToSql q b) => ToSql q (a, b) where recordToSql = recordToSql <&> recordToSql -recordToSql' :: Persistable a => RecordToSql a +recordToSql' :: Persistable q a => RecordToSql q a recordToSql' = recordSerializer persistable -updateValuesByUnique :: RecordToSql ra +updateValuesByUnique :: RecordToSql q ra -> KeyConstraint Unique ra -> ra - -> [SqlValue] + -> [q] updateValuesByUnique pr uk a = hd ++ tl where (hd, _uk:tl) = splitAt (index uk) (fromRecord pr a) -updateValuesByPrimary :: (HasKeyConstraint Primary a, ToSql a) => - a -> [SqlValue] +updateValuesByPrimary :: (HasKeyConstraint Primary a, ToSql q a) => + a -> [q] updateValuesByPrimary = updateValuesByUnique recordToSql (unique constraintKey)