hdbi 1.1.1 → 1.2.0
raw patch · 7 files changed
+278/−23 lines, 7 filesdep +derivedep +template-haskell
Dependencies added: derive, template-haskell
Files
- Database/HDBI.hs +2/−2
- Database/HDBI/SqlValue.hs +102/−8
- Database/HDBI/Types.hs +35/−8
- Language/Haskell/TH/HDBI.hs +98/−0
- hdbi.cabal +5/−1
- testsrc/dummydriver.hs +3/−3
- testsrc/sqlvalues.hs +33/−1
Database/HDBI.hs view
@@ -24,7 +24,7 @@ -- * Design notes --- | There is two typeclasses 'Connection' and 'Statement'. Each database driver+-- | There are two typeclasses 'Connection' and 'Statement'. Each database driver -- must provide it's own types (e.g. PostgreConnection and PostgreStatement in -- HDBI-postgresql driver) and instances for them. Driver can provide additional -- low-level functions not covered by these typeclasses.@@ -34,7 +34,7 @@ -- wrappers can hold database-specific type and call it's instance methods to -- interact with database. You can still use low-level functions provided for -- wrapped type by casting the wrapper back to the specific type by functions--- 'castStatement' and 'castConnection'. Here is how it's look like:+-- 'castStatement' and 'castConnection'. Here's how it look like: -- -- @ --genericStmtLen :: StmtWrapper -> IO Int
Database/HDBI/SqlValue.hs view
@@ -23,12 +23,14 @@ Stability : experimental Portability: portable -}- + module Database.HDBI.SqlValue ( ToSql(..) , FromSql(..)+ , ToRow(..)+ , FromRow(..) , ConvertError(..) , BitField(..) -- * SQL value marshalling@@ -37,22 +39,21 @@ where -import Database.HDBI.Formaters-import Database.HDBI.Parsers- -import Control.Applicative ((<$>))+import Control.Applicative ((<$>), (<*>)) import Control.Exception import Data.Attoparsec.Text.Lazy-import Data.Data (Data)-import Data.Ix (Ix) import Data.Bits (Bits)+import Data.Data (Data) import Data.Decimal import Data.Int+import Data.Ix (Ix) import Data.List (intercalate) import Data.Time import Data.Typeable import Data.UUID (UUID, fromString, toString) import Data.Word+import Database.HDBI.Formaters+import Database.HDBI.Parsers import qualified Blaze.ByteString.Builder as BB import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL@@ -96,7 +97,100 @@ Left e -> throw e Right a -> a +class ToRow a where+ toRow :: a -> [SqlValue] +class FromRow a where+ safeFromRow :: [SqlValue] -> Either ConvertError a++ fromRow :: [SqlValue] -> a+ fromRow sqls = case safeFromRow sqls of+ Left e -> throw e+ Right a -> a++wrongSqlList :: [SqlValue] -- ^ given list of SqlValues+ -> Int -- ^ expected length of list+ -> Either ConvertError a+wrongSqlList x c = Left $ ConvertError+ $ "Wrong count of SqlValues: " ++ (show $ length x)+ ++ " but expected: " ++ (show c)++-- instance (ToSql a) => ToRow a where+-- toRow a = [toSql a]++-- instance (FromSql a) => FromRow a where+-- safeFromRow [a] = safeFromSql a+-- safeFromRow x = wrongSqlList x 1++instance (ToSql a) => ToRow [a] where+ toRow a = map toSql a++instance (FromSql a) => FromRow [a] where+ safeFromRow a = mapM safeFromSql a++instance (ToSql a, ToSql b) => ToRow (a, b) where+ toRow (a, b) = [toSql a, toSql b]++instance (FromSql a, FromSql b) => FromRow (a, b) where+ safeFromRow [a, b] = (,) <$> safeFromSql a <*> safeFromSql b+ safeFromRow x = wrongSqlList x 2++instance (ToSql a, ToSql b, ToSql c) => ToRow (a, b, c) where+ toRow (a, b, c) = [toSql a, toSql b, toSql c]++instance (FromSql a, FromSql b, FromSql c) => FromRow (a, b, c) where+ safeFromRow [a, b, c] = (,,) <$> safeFromSql a <*> safeFromSql b <*> safeFromSql c+ safeFromRow x = wrongSqlList x 3++instance (ToSql a, ToSql b, ToSql c, ToSql d) => ToRow (a, b, c, d) where+ toRow (a, b, c, d) = [toSql a, toSql b, toSql c, toSql d]++instance (FromSql a, FromSql b, FromSql c, FromSql d) => FromRow (a, b, c, d) where+ safeFromRow [a, b, c, d] = (,,,) <$> safeFromSql a <*> safeFromSql b <*> safeFromSql c <*> safeFromSql d+ safeFromRow x = wrongSqlList x 4++instance (ToSql a, ToSql b, ToSql c, ToSql d, ToSql e) => ToRow (a, b, c, d, e) where+ toRow (a, b, c, d, e) = [toSql a, toSql b, toSql c, toSql d, toSql e]++instance (FromSql a, FromSql b, FromSql c, FromSql d, FromSql e) => FromRow (a, b, c, d, e) where+ safeFromRow [a, b, c, d, e] = (,,,,)+ <$> safeFromSql a+ <*> safeFromSql b+ <*> safeFromSql c+ <*> safeFromSql d+ <*> safeFromSql e+ safeFromRow x = wrongSqlList x 5+++instance (ToSql a, ToSql b, ToSql c, ToSql d, ToSql e, ToSql f) => ToRow (a, b, c, d, e, f) where+ toRow (a, b, c, d, e, f) = [toSql a, toSql b, toSql c, toSql d, toSql e, toSql f]++instance (FromSql a, FromSql b, FromSql c, FromSql d, FromSql e, FromSql f) => FromRow (a, b, c, d, e, f) where+ safeFromRow [a, b, c, d, e, f] = (,,,,,)+ <$> safeFromSql a+ <*> safeFromSql b+ <*> safeFromSql c+ <*> safeFromSql d+ <*> safeFromSql e+ <*> safeFromSql f+ safeFromRow x = wrongSqlList x 6++instance (ToSql a, ToSql b, ToSql c, ToSql d, ToSql e, ToSql f, ToSql g) => ToRow (a, b, c, d, e, f, g) where+ toRow (a, b, c, d, e, f, g) = [toSql a, toSql b, toSql c, toSql d, toSql e, toSql f, toSql g]++instance (FromSql a, FromSql b, FromSql c, FromSql d, FromSql e, FromSql f, FromSql g) => FromRow (a, b, c, d, e, f, g) where+ safeFromRow [a, b, c, d, e, f, g] = (,,,,,,)+ <$> safeFromSql a+ <*> safeFromSql b+ <*> safeFromSql c+ <*> safeFromSql d+ <*> safeFromSql e+ <*> safeFromSql f+ <*> safeFromSql g+ safeFromRow x = wrongSqlList x 7+ + + -- | Show parser detail error showFail :: [String] -- ^ List of contexts of parser -> String -- ^ Error message@@ -568,7 +662,7 @@ safeFromSql (SqlLocalTime lt) = incompatibleTypes lt (undefined :: Bool) safeFromSql SqlNull = nullConvertError (undefined :: Bool) - + instance ToSql BitField where toSql = SqlBitField
Database/HDBI/Types.hs view
@@ -33,11 +33,17 @@ , StatementStatus(..) , StmtWrapper(..) , SqlError(..)- -- * functions+ -- * Auxiliary functions , castConnection , castStatement , withTransaction , withStatement+ , runRow+ , runManyRows+ , executeRow+ , executeManyRows+ , fetchRow+ , fetchAllRows ) where @@ -51,7 +57,7 @@ import Data.Monoid (Monoid(..), Endo(..)) import Data.String (IsString(..)) import Data.Typeable-import Database.HDBI.SqlValue (SqlValue)+import Database.HDBI.SqlValue (SqlValue, ToRow(..), FromRow(..)) import qualified Data.Text.Lazy as TL -- | Error throwing by driver when database operation fails@@ -235,12 +241,12 @@ -- -- NOTE: You still need to explicitly finish the statement after receiving -- Nothing, unlike with old HDBC interface.- fetchRow :: stmt -> IO (Maybe [SqlValue])+ fetch :: stmt -> IO (Maybe [SqlValue]) -- | Optional method to strictly fetch all rows from statement. Has default- -- implementation through 'fetchRow'.- fetchAllRows :: stmt -> IO [[SqlValue]]- fetchAllRows stmt = do+ -- implementation through 'fetch'.+ fetchAll :: stmt -> IO [[SqlValue]]+ fetchAll stmt = do e <- f mempty return $ (appEndo e) [] where@@ -273,8 +279,8 @@ statementStatus (StmtWrapper stmt) = statementStatus stmt finish (StmtWrapper stmt) = finish stmt reset (StmtWrapper stmt) = reset stmt- fetchRow (StmtWrapper stmt) = fetchRow stmt- fetchAllRows (StmtWrapper stmt) = fetchAllRows stmt+ fetch (StmtWrapper stmt) = fetch stmt+ fetchAll (StmtWrapper stmt) = fetchAll stmt getColumnNames (StmtWrapper stmt) = getColumnNames stmt getColumnsCount (StmtWrapper stmt) = getColumnsCount stmt originalQuery (StmtWrapper stmt) = originalQuery stmt@@ -325,3 +331,24 @@ withStatement conn query = bracket (prepare conn query) finish+++-- | same as `run` but uses `ToRow` instance+runRow :: (Connection con, ToRow a) => con -> Query -> a -> IO ()+runRow con query row = run con query $ toRow row++-- | same as `runMany` but uses `ToRow`+runManyRows :: (Connection con, ToRow a) => con -> Query -> [a] -> IO ()+runManyRows con query rows = runMany con query $ map toRow rows++executeRow :: (Statement stmt, ToRow a) => stmt -> a -> IO ()+executeRow stmt row = execute stmt $ toRow row++executeManyRows :: (Statement stmt, ToRow a) => stmt -> [a] -> IO ()+executeManyRows stmt rows = executeMany stmt $ map toRow rows++fetchRow :: (Statement stmt, FromRow a) => stmt -> IO (Maybe a)+fetchRow stmt = fetch stmt >>= return . (fromRow <$>)++fetchAllRows :: (Statement stmt, FromRow a) => stmt -> IO [a]+fetchAllRows stmt = fetchAll stmt >>= return . map fromRow
+ Language/Haskell/TH/HDBI.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE+ TemplateHaskell+, QuasiQuotes+ #-}++module Language.Haskell.TH.HDBI+ (+ deriveToRow+ , deriveFromRow+ ) where++-- import Control.Applicative+import Control.Monad+import Control.Applicative+import Database.HDBI.SqlValue (ToRow(..),+ FromRow(..),+ FromSql(..),+ ToSql(..),+ ConvertError(..))+import Language.Haskell.TH+++-- | return constructor name and fields count, or Nothing if data constructor is+-- infix+getTParams :: String -> Name -> Q (Name, Maybe Int)+getTParams exc name = do+ tcon <- reify name+ case tcon of+ (TyConI dec) -> do+ case dec of+ (DataD _ _ vars constrs _) -> do+ checkVars vars+ case constrs of+ [con] -> getTParams' con+ _ -> fl $ "data " ++ (show name) ++ " should have exactly one constructor"++ (NewtypeD _ _ vars con _) -> do+ checkVars vars+ getTParams' con++ _ -> fl $ "deriveToRow can derive just for data with one constructor or for newtypes"+ _ -> fl $ (show name) ++ " must be a type"++ where+ fl x = fail $ exc ++ x+ checkVars [] = return ()+ checkVars _ = fl $ "type " ++ show name ++ " should not have type variables"++ getTParams' :: Con -> Q (Name, Maybe Int)+ getTParams' (NormalC n fields) = return (n, Just $ length fields)+ getTParams' (RecC n fields) = return (n, Just $ length fields)+ getTParams' (InfixC _ n _) = return (n, Nothing)+ getTParams' _ = fl $ "data constructors should not contain typevar boundries for " ++ show name+++-- | Derive `ToRow` instance for any data with one constructor or for newtype+deriveToRow :: Name -> Q [Dec]+deriveToRow name = do+ (con, fields) <- getTParams "deriveToRow: " name+ names <- case fields of+ Just fl -> replicateM fl $ newName "val"+ Nothing -> replicateM 2 $ newName "val"++ return [InstanceD [] (AppT (ConT ''ToRow) (ConT name))+ [FunD 'toRow+ [Clause [mkPattern con fields names]+ (NormalB $ ListE $ map (\nm -> AppE (VarE 'toSql) (VarE nm)) names) [] ]]]+ where+ mkPattern con Nothing [n1, n2] = InfixP (VarP n1) con (VarP n2)+ mkPattern con (Just _) names = ConP con $ map VarP names+++deriveFromRow :: Name -> Q [Dec]+deriveFromRow name = do+ (con, fields) <- getTParams "deriveFromRow: " name+ names <- case fields of+ Just fl -> replicateM fl $ newName "val"+ Nothing -> replicateM 2 $ newName "val"+ xname <- newName "x"+ return [InstanceD [] (AppT (ConT ''FromRow) (ConT name))+ [FunD 'safeFromRow+ [Clause [ListP $ map VarP names]+ (NormalB $ UInfixE (mkCon fields con) (VarE '(<$>)) (foldedFromSql names)) []+ ,Clause [VarP xname]+ (NormalB $ AppE (ConE 'Left) (AppE (ConE 'ConvertError)+ (UInfixE+ (LitE $ StringL $ "Could not construct " ++ show name+ ++ ": query must return exactly "+ ++ (show $ length names) ++ " values but not " )+ (VarE '(++))+ (AppE (VarE 'show) (AppE (VarE 'length) (VarE xname)))))) []]]]++ where+ foldedFromSql names = foldl1 (\a b -> UInfixE a (VarE '(<*>)) b)+ $ map (\n -> AppE (VarE 'safeFromSql) (VarE n)) names++ mkCon (Just _) con = ConE con+ mkCon Nothing con = ParensE $ ConE con
hdbi.cabal view
@@ -1,5 +1,5 @@ Name: hdbi-Version: 1.1.1+Version: 1.2.0 License: BSD3 Maintainer: Aleksey Uymanov <s9gf4ult@gmail.com> Author: John Goerzen@@ -35,6 +35,7 @@ , deepseq , old-locale , stm+ , template-haskell , text , time >= 1.1.2.4 && <=1.5 , uuid >= 1.0.0@@ -53,6 +54,7 @@ , Database.HDBI.Types , Database.HDBI.Formaters , Database.HDBI.Parsers+ , Language.Haskell.TH.HDBI Test-Suite sqlvalues Type: exitcode-stdio-1.0@@ -69,9 +71,11 @@ , bytestring , containers , deepseq+ , derive , old-locale , quickcheck-assertions , quickcheck-instances+ , template-haskell , test-framework , test-framework-hunit , test-framework-quickcheck2
testsrc/dummydriver.hs view
@@ -142,7 +142,7 @@ return StatementNew _ -> return StatementNew - fetchRow stmt = modifyMVar (dsSelecting stmt) $ \slct -> case slct of+ fetch stmt = modifyMVar (dsSelecting stmt) $ \slct -> case slct of Nothing -> return (Nothing, Nothing) Just sl -> do dt <- readMVar $ dcData $ dsConnection stmt@@ -246,7 +246,7 @@ finish s3 ss <- prepare c "select" executeRaw ss- outdt <- fetchAllRows ss+ outdt <- fetchAll ss outdt `shouldBe` indt noStatementsAfterDisconnect :: Assertion@@ -267,7 +267,7 @@ withStatement c "query string" $ \st -> do -- this statement should be -- finished executeRaw st- _ <- fetchRow st+ _ <- fetch st return () s <- prepare c "query string" -- but this should not executeRaw s
testsrc/sqlvalues.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables+, TemplateHaskell , FlexibleContexts , CPP #-}@@ -10,11 +11,13 @@ import Data.Decimal import Data.Int import Data.List (intercalate)+import Data.DeriveTH import Data.Time import Data.UUID import Data.Word-import Database.HDBI (ToSql(..), FromSql(..), BitField(..))+import Database.HDBI (ToSql(..), FromSql(..), BitField(..), FromRow(..), ToRow(..)) import Database.HDBI.Parsers+import Language.Haskell.TH.HDBI import Test.Framework import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2@@ -29,7 +32,25 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as TL +data D1 = D1 Int+ deriving (Show, Eq)+data D3 = D3 Int String Double+ deriving (Show, Eq)+data D4 = D4 UUID String UTCTime Decimal+ deriving (Show, Eq)+deriveToRow ''D1+deriveFromRow ''D1+deriveToRow ''D3+deriveFromRow ''D3+deriveToRow ''D4+deriveFromRow ''D4+$(derive makeArbitrary ''D1)+$(derive makeArbitrary ''D3)+$(derive makeArbitrary ''D4) +++ #if MIN_VERSION_Decimal(0,3,1) -- Decimal-0.2.4 has no Arbitrary instance in library any more instance (Arbitrary i, Integral i) => Arbitrary (DecimalRaw i) where@@ -87,6 +108,16 @@ , testProperty "with Maybe Int" $ \(mi :: Maybe Int) -> mi == (fromSql $ toSql mi) -- can not represent Null as ByteString ] +thTests :: Test+thTests = testGroup "TH tests"+ [ testProperty "data D1 = D1 Int" $ \(d :: D1) -> testFromToRow d+ , testProperty "data D3 = D3 Int String Double" $ \(d :: D3) -> testFromToRow d+ , testProperty "data D4 = D4 UUID String UTCTime Decimal" $ \(d :: D4) -> testFromToRow d+ ]++testFromToRow :: (FromRow a, ToRow a, Show a, Eq a) => a -> Result+testFromToRow a = a ==? (fromRow $ toRow a)+ parserFail :: [String] -> String -> String parserFail cont msg = "parser failed in context: " ++ (intercalate ", " cont)@@ -153,4 +184,5 @@ main :: IO () main = defaultMain [ sqlValueTestGroup , parserTests+ , thTests ]