odbc 0.1.1 → 0.2.0
raw patch · 7 files changed
+210/−176 lines, 7 files
Files
- CHANGELOG +17/−0
- app/Main.hs +2/−1
- odbc.cabal +2/−2
- src/Database/ODBC/Conversion.hs +46/−66
- src/Database/ODBC/Internal.hs +46/−44
- src/Database/ODBC/SQLServer.hs +10/−10
- test/Main.hs +87/−53
+ CHANGELOG view
@@ -0,0 +1,17 @@+0.2.0:+ * Drop Maybes, use NullValue.++0.1.1:+ * Fix Smalldatetime ToSql instance to set seconds to 0.+ * Add support for numeric.++0.1.0:+ * Removed instance of ToSql for LocalTime, added two new+ newtypes: Datetime2 and Smalldatetime.++0.0.4:+ * Improved non-Unicode field support: varchar/text treated as+ actual binary, not "characters" in the SQL server sense.++0.0.3:+ * Handle multiple statements in exec call.
app/Main.hs view
@@ -45,11 +45,12 @@ putStr "> " catch (fmap Just T.getLine) (\(_ :: IOException) -> pure Nothing) output count row = do- putStrLn (intercalate ", " (map (maybe "NULL" showColumn) row))+ putStrLn (intercalate ", " (map showColumn row)) pure (ODBC.Continue (count + 1)) where showColumn = \case+ ODBC.NullValue -> "NULL" ODBC.TextValue t -> show t ODBC.ByteStringValue bs -> show bs ODBC.BinaryValue bs -> show bs
odbc.cabal view
@@ -5,11 +5,11 @@ suite runs on OS X, Windows and Linux. copyright: FP Complete 2018 maintainer: chrisdone@fpcomplete.com-version: 0.1.1+version: 0.2.0 license: BSD3 license-file: LICENSE build-type: Simple-extra-source-files: README.md doc/style.css doc/patch.sh doc/init.js doc/highlight.pack.js+extra-source-files: README.md CHANGELOG doc/style.css doc/patch.sh doc/init.js doc/highlight.pack.js cabal-version: >=1.10 homepage: https://github.com/fpco/odbc
src/Database/ODBC/Conversion.hs view
@@ -24,116 +24,95 @@ -- | Convert from a 'Value' to a regular Haskell value. class FromValue a where- fromValue :: Maybe Value -> Either String a+ fromValue :: Value -> Either String a -- ^ The 'String' is used for a helpful error message. --- | Expect a value to be non-null.-withNonNull ::- (Value -> Either String a) -> Maybe Value -> Either String a-withNonNull f =- \case- Nothing -> Left "Unexpected NULL for value"- Just v -> f v- instance FromValue a => FromValue (Maybe a) where fromValue = \case- Nothing -> pure Nothing- Just v -> fmap Just (fromValue (Just v))+ NullValue -> pure Nothing+ v -> fmap Just (fromValue v) instance FromValue Value where- fromValue = withNonNull pure+ fromValue = pure instance FromValue Text where fromValue =- withNonNull- (\case- TextValue x -> pure (id x)- v -> Left ("Expected Text, but got: " ++ show v))+ (\case+ TextValue x -> pure (id x)+ v -> Left ("Expected Text, but got: " ++ show v)) instance FromValue LT.Text where fromValue =- withNonNull- (\case- TextValue x -> pure (LT.fromStrict x)- v -> Left ("Expected Text, but got: " ++ show v))+ (\case+ TextValue x -> pure (LT.fromStrict x)+ v -> Left ("Expected Text, but got: " ++ show v)) instance FromValue ByteString where fromValue =- withNonNull- (\case- ByteStringValue x -> pure (id x)- v -> Left ("Expected ByteString, but got: " ++ show v))+ (\case+ ByteStringValue x -> pure (id x)+ v -> Left ("Expected ByteString, but got: " ++ show v)) instance FromValue Binary where fromValue =- withNonNull- (\case- BinaryValue x -> pure (id x)- v -> Left ("Expected Binary, but got: " ++ show v))+ (\case+ BinaryValue x -> pure (id x)+ v -> Left ("Expected Binary, but got: " ++ show v)) instance FromValue L.ByteString where fromValue =- withNonNull- (\case- ByteStringValue x -> pure (L.fromStrict x)- v -> Left ("Expected ByteString, but got: " ++ show v))+ (\case+ ByteStringValue x -> pure (L.fromStrict x)+ v -> Left ("Expected ByteString, but got: " ++ show v)) instance FromValue Int where fromValue =- withNonNull- (\case- IntValue x -> pure (id x)- v -> Left ("Expected Int, but got: " ++ show v))+ (\case+ IntValue x -> pure (id x)+ v -> Left ("Expected Int, but got: " ++ show v)) instance FromValue Double where fromValue =- withNonNull- (\case- DoubleValue x -> pure (id x)- v -> Left ("Expected Double, but got: " ++ show v))+ (\case+ DoubleValue x -> pure (id x)+ v -> Left ("Expected Double, but got: " ++ show v)) instance FromValue Float where fromValue =- withNonNull- (\case- FloatValue x -> pure (realToFrac x)- v -> Left ("Expected Float, but got: " ++ show v))+ (\case+ FloatValue x -> pure (realToFrac x)+ v -> Left ("Expected Float, but got: " ++ show v)) instance FromValue Word8 where fromValue =- withNonNull- (\case- ByteValue x -> pure x- v -> Left ("Expected Byte, but got: " ++ show v))+ (\case+ ByteValue x -> pure x+ v -> Left ("Expected Byte, but got: " ++ show v)) instance FromValue Bool where fromValue =- withNonNull- (\case- BoolValue x -> pure (id x)- v -> Left ("Expected Bool, but got: " ++ show v))+ (\case+ BoolValue x -> pure (id x)+ v -> Left ("Expected Bool, but got: " ++ show v)) instance FromValue Day where fromValue =- withNonNull- (\case- DayValue x -> pure (id x)- v -> Left ("Expected Day, but got: " ++ show v))+ (\case+ DayValue x -> pure (id x)+ v -> Left ("Expected Day, but got: " ++ show v)) instance FromValue TimeOfDay where fromValue =- withNonNull- (\case- TimeOfDayValue x -> pure (id x)- v -> Left ("Expected TimeOfDay, but got: " ++ show v))+ (\case+ TimeOfDayValue x -> pure (id x)+ v -> Left ("Expected TimeOfDay, but got: " ++ show v)) instance FromValue LocalTime where fromValue =- withNonNull- (\case- LocalTimeValue x -> pure (id x)- v -> Left ("Expected LocalTime, but got: " ++ show v))+ (\case+ LocalTimeValue x -> pure (id x)+ v -> Left ("Expected LocalTime, but got: " ++ show v)) -------------------------------------------------------------------------------- -- Producing rows@@ -144,9 +123,10 @@ -- e.g. @[Maybe Value]@ if you don't know what you're dealing with, or -- a tuple e.g. @(Text, Int, Bool)@. class FromRow r where- fromRow :: [Maybe Value] -> Either String r+ fromRow :: [Value] -> Either String r instance FromValue v => FromRow (Maybe v) where+ fromRow [NullValue] = Right Nothing fromRow [v] = fromValue v fromRow _ = Left "Unexpected number of fields in row" @@ -154,7 +134,7 @@ fromRow [v] = fmap Identity (fromValue v) fromRow _ = Left "Unexpected number of fields in row" -instance FromRow [Maybe Value] where+instance FromRow [Value] where fromRow = pure instance FromRow Value where
src/Database/ODBC/Internal.hs view
@@ -123,6 +123,8 @@ -- ^ Time of day (hh, mm, ss + fractional) values. | LocalTimeValue !LocalTime -- ^ Local date and time.+ | NullValue+ -- ^ SQL null value. deriving (Eq, Show, Typeable, Ord, Generic, Data) instance NFData Value @@ -238,7 +240,7 @@ MonadIO m => Connection -- ^ A connection to the database. -> Text -- ^ SQL query.- -> m [[Maybe Value]]+ -> m [[Value]] -- ^ A strict list of rows. This list is not lazy, so if you are -- retrieving a large data set, be aware that all of it will be -- loaded into memory.@@ -254,7 +256,7 @@ (MonadIO m, MonadUnliftIO m) => Connection -- ^ A connection to the database. -> Text -- ^ SQL query.- -> (state -> [Maybe Value] -> m (Step state))+ -> (state -> [Value] -> m (Step state)) -- ^ A stepping function that gets as input the current @state@ and -- a row, returning either a new @state@ or a final @result@. -> state@@ -329,7 +331,7 @@ fetchIterator :: Ptr EnvAndDbc -> UnliftIO m- -> (state -> [Maybe Value] -> m (Step state))+ -> (state -> [Value] -> m (Step state)) -> state -> SQLHSTMT s -> IO state@@ -382,7 +384,7 @@ (fetchAllResults dbc stmt) -- | Fetch all rows from a statement.-fetchStatementRows :: Ptr EnvAndDbc -> SQLHSTMT s -> IO [[Maybe Value]]+fetchStatementRows :: Ptr EnvAndDbc -> SQLHSTMT s -> IO [[Value]] fetchStatementRows dbc stmt = do SQLSMALLINT cols <- withMalloc@@ -457,7 +459,7 @@ })))))))) -- | Pull data for the given column.-getData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> Column -> IO (Maybe Value)+getData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> Column -> IO Value getData dbc stmt i col = if | colType == sql_longvarchar -> getBytesData dbc stmt i | colType == sql_varchar -> getBytesData dbc stmt i@@ -471,9 +473,9 @@ (\bitPtr -> do mlen <- getTypedData dbc stmt sql_c_bit i (coerce bitPtr) (SQLLEN 1) case mlen of- Nothing -> pure Nothing+ Nothing -> pure NullValue Just {} ->- fmap (Just . BoolValue . (/= (0 :: Word8))) (peek bitPtr))+ fmap (BoolValue . (/= (0 :: Word8))) (peek bitPtr)) | colType == sql_double -> withMalloc (\doublePtr -> do@@ -481,10 +483,10 @@ getTypedData dbc stmt sql_c_double i (coerce doublePtr) (SQLLEN 8) -- float is 8 bytes: https://technet.microsoft.com/en-us/library/ms172424(v=sql.110).aspx case mlen of- Nothing -> pure Nothing+ Nothing -> pure NullValue Just {} -> do !d <- fmap DoubleValue (peek doublePtr)- pure (Just d))+ pure d) | colType == sql_float -> withMalloc (\floatPtr -> do@@ -493,10 +495,10 @@ -- SQLFLOAT is covered by SQL_C_DOUBLE: https://docs.microsoft.com/en-us/sql/odbc/reference/appendixes/c-data-types -- Float is 8 bytes: https://technet.microsoft.com/en-us/library/ms172424(v=sql.110).aspx case mlen of- Nothing -> pure Nothing+ Nothing -> pure NullValue Just {} -> do !d <- fmap DoubleValue (peek floatPtr)- pure (Just d))+ pure d) | colType == sql_real -> withMalloc (\floatPtr -> do@@ -505,13 +507,13 @@ -- SQLFLOAT is covered by SQL_C_DOUBLE: https://docs.microsoft.com/en-us/sql/odbc/reference/appendixes/c-data-types -- Float is 8 bytes: https://technet.microsoft.com/en-us/library/ms172424(v=sql.110).aspx case mlen of- Nothing -> pure Nothing+ Nothing -> pure NullValue Just {} -> do !d <- fmap (FloatValue . (realToFrac :: Double -> Float)) (peek floatPtr)- pure (Just d))+ pure d) | colType == sql_numeric || colType == sql_decimal -> withMalloc (\floatPtr -> do@@ -520,20 +522,20 @@ -- NUMERIC/DECIMAL can be read as FLOAT -- Float is 8 bytes: https://technet.microsoft.com/en-us/library/ms172424(v=sql.110).aspx case mlen of- Nothing -> pure Nothing+ Nothing -> pure NullValue Just {} -> do !d <- fmap DoubleValue (peek floatPtr)- pure (Just d))+ pure d) | colType == sql_integer -> withMalloc (\intPtr -> do mlen <- getTypedData dbc stmt sql_c_long i (coerce intPtr) (SQLLEN 4) case mlen of- Nothing -> pure Nothing+ Nothing -> pure NullValue Just {} -> fmap- (Just . IntValue . fromIntegral)+ (IntValue . fromIntegral) (peek (intPtr :: Ptr Int32))) | colType == sql_bigint -> withMalloc@@ -541,10 +543,10 @@ mlen <- getTypedData dbc stmt sql_c_bigint i (coerce intPtr) (SQLLEN 8) case mlen of- Nothing -> pure Nothing+ Nothing -> pure NullValue Just {} -> fmap- (Just . IntValue . fromIntegral)+ (IntValue . fromIntegral) (peek (intPtr :: Ptr Int64))) | colType == sql_smallint -> withMalloc@@ -552,10 +554,10 @@ mlen <- getTypedData dbc stmt sql_c_short i (coerce intPtr) (SQLLEN 2) case mlen of- Nothing -> pure Nothing+ Nothing -> pure NullValue Just {} -> fmap- (Just . IntValue . fromIntegral)+ (IntValue . fromIntegral) (peek (intPtr :: Ptr Int16))) | colType == sql_tinyint -> withMalloc@@ -563,8 +565,8 @@ mlen <- getTypedData dbc stmt sql_c_short i (coerce intPtr) (SQLLEN 1) case mlen of- Nothing -> pure Nothing- Just {} -> fmap (Just . ByteValue) (peek (intPtr :: Ptr Word8)))+ Nothing -> pure NullValue+ Just {} -> fmap ByteValue (peek (intPtr :: Ptr Word8))) | colType == sql_type_date -> withMallocBytes 3@@ -572,10 +574,10 @@ mlen <- getTypedData dbc stmt sql_c_date i (coerce datePtr) (SQLLEN 3) case mlen of- Nothing -> pure Nothing+ Nothing -> pure NullValue Just {} -> fmap- (Just . DayValue)+ DayValue (fromGregorian <$> (fmap fromIntegral (odbc_DATE_STRUCT_year datePtr)) <*> (fmap fromIntegral (odbc_DATE_STRUCT_month datePtr)) <*>@@ -594,10 +596,10 @@ (coerce datePtr) (SQLLEN 12) case mlen of- Nothing -> pure Nothing+ Nothing -> pure NullValue Just {} -> fmap- (Just . TimeOfDayValue)+ TimeOfDayValue (TimeOfDay <$> (fmap fromIntegral (odbc_TIME_STRUCT_hour datePtr)) <*> (fmap fromIntegral (odbc_TIME_STRUCT_minute datePtr)) <*>@@ -615,10 +617,10 @@ (coerce timestampPtr) (SQLLEN 16) case mlen of- Nothing -> pure Nothing+ Nothing -> pure NullValue Just {} -> fmap- (Just . LocalTimeValue)+ LocalTimeValue (LocalTime <$> (fromGregorian <$> (fmap fromIntegral (odbc_TIMESTAMP_STRUCT_year timestampPtr)) <*>@@ -649,8 +651,8 @@ colType = columnType col -- | Get a GUID as a binary value.-getGuid :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO (Maybe Value)-getGuid dbc stmt column =+getGuid :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO Value+getGuid dbc stmt column = do uninterruptibleMask_ (do bufferp <- callocBytes odbcGuidBytes void@@ -662,14 +664,14 @@ (coerce bufferp) (SQLLEN odbcGuidBytes)) !bs <- S.unsafePackMallocCStringLen (bufferp, odbcGuidBytes)- evaluate (Just (BinaryValue (Binary bs))))+ evaluate (BinaryValue (Binary bs))) -- | Get the column's data as a vector of CHAR.-getBytesData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO (Maybe Value)+getBytesData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO Value getBytesData dbc stmt column = do mavailableBytes <- getSize dbc stmt sql_c_binary column case mavailableBytes of- Just 0 -> pure (Just (ByteStringValue mempty))+ Just 0 -> pure (ByteStringValue mempty) Just availableBytes -> uninterruptibleMask_ (do let allocBytes = availableBytes + 1@@ -685,15 +687,15 @@ bs <- S.unsafePackMallocCStringLen (bufferp, fromIntegral availableBytes)- evaluate (Just (ByteStringValue bs)))- Nothing -> pure Nothing+ evaluate (ByteStringValue bs))+ Nothing -> pure NullValue -- | Get the column's data as raw binary.-getBinaryData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO (Maybe Value)+getBinaryData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO Value getBinaryData dbc stmt column = do mavailableBinary <- getSize dbc stmt sql_c_binary column case mavailableBinary of- Just 0 -> pure (Just (BinaryValue (Binary mempty)))+ Just 0 -> pure (BinaryValue (Binary mempty)) Just availableBinary -> uninterruptibleMask_ (do let allocBinary = availableBinary@@ -709,16 +711,16 @@ bs <- S.unsafePackMallocCStringLen (bufferp, fromIntegral availableBinary)- evaluate (Just (BinaryValue (Binary bs))))- Nothing -> pure Nothing+ evaluate (BinaryValue (Binary bs)))+ Nothing -> pure NullValue -- | Get the column's data as a text string.-getTextData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO (Maybe Value)+getTextData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO Value getTextData dbc stmt column = do mavailableChars <- getSize dbc stmt sql_c_wchar column case mavailableChars of- Just 0 -> pure (Just (TextValue mempty))- Nothing -> pure Nothing+ Just 0 -> pure (TextValue mempty)+ Nothing -> pure NullValue Just availableBytes -> do let allocBytes = availableBytes + 2 withMallocBytes@@ -734,7 +736,7 @@ (SQLLEN (fromIntegral allocBytes))) t <- T.fromPtr bufferp (fromIntegral (div availableBytes 2)) let !v = TextValue t- pure (Just v))+ pure v) -- | Get some data into the given pointer. getTypedData ::
src/Database/ODBC/SQLServer.hs view
@@ -106,7 +106,7 @@ -- exec conn "DROP TABLE IF EXISTS example" -- exec conn "CREATE TABLE example (id int, name ntext, likes_tacos bit)" -- exec conn "INSERT INTO example VALUES (1, \'Chris\', 0), (2, \'Mary\', 1)"--- rows <- query conn "SELECT * FROM example" :: IO [[Maybe Value]]+-- rows <- query conn "SELECT * FROM example" :: IO [[Value]] -- print rows -- rows2 <- query conn "SELECT * FROM example" :: IO [(Int,Text,Bool)] -- print rows2@@ -123,7 +123,7 @@ -- The output of this program for @rows@: -- -- @--- [[Just (IntValue 1),Just (TextValue \"Chris\"),Just (BoolValue False)],[Just (IntValue 2),Just (TextValue \"Mary\"),Just (BoolValue True)]]+-- [[IntValue 1, TextValue \"Chris\", BoolValue False],[ IntValue 2, TextValue \"Mary\", BoolValue True]] -- @ -- -- The output for @rows2@:@@ -186,16 +186,12 @@ -- stream -- conn -- \"SELECT * FROM example\"--- (\\longest mtext ->+-- (\\longest text -> -- pure -- (Continue--- (maybe--- longest--- (\\text ->--- if T.length text > T.length longest--- then text--- else longest)--- mtext)))+-- (if T.length text > T.length longest+-- then text+-- else longest))) -- \"\" -- print longest) -- @@@ -272,6 +268,9 @@ class ToSql a where toSql :: a -> Query +instance ToSql a => ToSql (Maybe a) where+ toSql = maybe (Query (Seq.fromList [ValuePart NullValue])) toSql+ -- | Converts whatever the 'Value' is to SQL. instance ToSql Value where toSql = Query . Seq.fromList . pure . ValuePart@@ -444,6 +443,7 @@ renderValue :: Value -> Text renderValue = \case+ NullValue -> "NULL" TextValue t -> "(N'" <> T.concatMap escapeChar t <> "')" BinaryValue (Internal.Binary bytes) -> "0x" <>
test/Main.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE BangPatterns #-}@@ -160,7 +163,7 @@ quickCheckRoundtrip @ByteString "ByteString" ("varchar(" <> (show maxStringLen) <> ")") quickCheckRoundtrip @TestBinary "ByteString" ("binary(" <> (show maxStringLen) <> ")") quickCheckRoundtrip @Binary "ByteString" ("varbinary(" <> (show maxStringLen) <> ")")- quickCheckRoundtrip @TestGUID "GUID" "uniqueidentifier"+ quickCheckRoundtripEx @TestGUID False "GUID" "uniqueidentifier" connectivity :: Spec connectivity = do@@ -201,19 +204,19 @@ Internal.close c shouldBe rows- [ [ Just (IntValue 123)- , Just (ByteStringValue "abc")- , Just (BoolValue True)- , Just (TextValue "wib")- , Just (DoubleValue 2.415)+ [ [ (IntValue 123)+ , (ByteStringValue "abc")+ , (BoolValue True)+ , (TextValue "wib")+ , (DoubleValue 2.415) ]- , [ Just (IntValue 456)- , Just (ByteStringValue "def")- , Just (BoolValue False)- , Just (TextValue "wibble")- , Just (DoubleValue 0.9999999999999)+ , [ (IntValue 456)+ , (ByteStringValue "def")+ , (BoolValue False)+ , (TextValue "wibble")+ , (DoubleValue 0.9999999999999) ]- , [Nothing, Nothing, Nothing, Nothing, Nothing]+ , [NullValue, NullValue, NullValue, NullValue, NullValue] ]) it "Querying commands with no results"@@ -301,11 +304,20 @@ shouldBe result input) quickCheckRoundtrip ::- forall t. (Arbitrary t, Eq t, Show t, ToSql t, FromValue t)+ forall t. (Arbitrary t, Eq t, Show t, ToSql t, FromValue t, ToSql (Maybe t)) => String -> String -> Spec-quickCheckRoundtrip l typ =+quickCheckRoundtrip = quickCheckRoundtripEx @t True++quickCheckRoundtripEx ::+ forall t.+ (Arbitrary t, Eq t, Show t, ToSql t, FromValue t, ToSql (Maybe t))+ => Bool+ -> String+ -> String+ -> Spec+quickCheckRoundtripEx testMaybes l typ = beforeAll (do c <- connectWithString SQLServer.exec c "DROP TABLE IF EXISTS test"@@ -313,44 +325,66 @@ pure c) (afterAll SQLServer.close- (it- ("QuickCheck roundtrip: HS=" <> l <> ", SQL=" <> typ)- (\c ->- property- (\input ->- monadicIO- (do SQLServer.exec c "TRUNCATE TABLE test"- let q =- "INSERT INTO test VALUES (" <> toSql (input :: t) <>- ")"- liftIO- (catch- (SQLServer.exec c q)- (\e -> do- print (e :: SomeException)- T.putStrLn (SQLServer.renderQuery q)- SQLServer.close c- throwIO e))- [Identity result] <-- SQLServer.query c "SELECT f FROM test"- when- (result /= input)- (liftIO- (putStr- (unlines- [ "Expected: " ++ show input- , "Actual: " ++ show result- , "Query was: " ++ show q- ])))- monitor- (counterexample- (unlines- [ "Expected: " ++ show input- , "Actual: " ++ show result- , "Query was: " ++- T.unpack (SQLServer.renderQuery q)- ]))- assert (result == input))))))+ (let makeIt ::+ forall t'.+ ( Arbitrary t'+ , Show t'+ , ToSql t'+ , FromValue t'+ , Eq t'+ , ToSql (Maybe t')+ )+ => String+ -> String+ -> (t -> t')+ -> SpecWith Connection+ makeIt l' typ' f =+ it+ ("QuickCheck roundtrip: HS=" <> l' <> ", SQL=" <> typ')+ (\c ->+ property+ (\(f -> input) ->+ monadicIO+ (do SQLServer.exec c "TRUNCATE TABLE test"+ let q =+ "INSERT INTO test VALUES (" <> toSql input <>+ ")"+ liftIO+ (catch+ (SQLServer.exec c q)+ (\e -> do+ print (e :: SomeException)+ T.putStrLn (SQLServer.renderQuery q)+ SQLServer.close c+ throwIO e))+ [Identity result] <-+ SQLServer.query c "SELECT f FROM test"+ when+ (result /= input)+ (liftIO+ (putStr+ (unlines+ [ "Expected: " ++ show input+ , "Actual: " ++ show result+ , "Query was: " ++ show q+ ])))+ monitor+ (counterexample+ (unlines+ [ "Expected: " ++ show input+ , "Actual: " ++ show result+ , "Query was: " +++ T.unpack (SQLServer.renderQuery q)+ ]))+ assert (result == input))))+ in do makeIt l typ id+ when+ testMaybes+ (do makeIt ("Maybe " ++ l) typ Just+ makeIt+ ("Maybe " ++ l)+ (typ ++ " (NULL)")+ (const Nothing :: a -> Maybe a)))) quickCheckOneway :: forall t. (Arbitrary t, Eq t, Show t, ToSql t, FromValue t)@@ -434,7 +468,7 @@ result :: Either String t result = case rows of- Right [[Just x]] ->+ Right [[x]] -> case unpack x of Nothing -> Left "Couldn't unpack value." Just v -> pure v