duckdb-simple 0.1.2.1 → 0.1.2.2
raw patch · 6 files changed
+429/−14 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +1/−1
- duckdb-simple.cabal +2/−1
- src/Database/DuckDB/Simple/LogicalRep.hs +10/−2
- src/Database/DuckDB/Simple/ToField.hs +6/−10
- test/Properties.hs +408/−0
- test/Spec.hs +2/−0
CHANGELOG.md view
@@ -1,6 +1,6 @@ # Changelog -## Unreleased+## 0.1.2.2 - Add support for reading and writing arrays. - Added `Database.DuckDB.Simple.Generic` with GHC generics helpers (`GToField`/`GFromField`) for encoding records as DuckDB STRUCTs and sum types as UNIONs, plus a `ViaDuckDB` newtype for convenient @DerivingVia@ support. - Added `DuckValue` instances for `[]`, `Array Int a`, and `Map k v` to enable lists, arrays, and maps as fields within generically-encoded structs and unions.
duckdb-simple.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.4 name: duckdb-simple-version: 0.1.2.1+version: 0.1.2.2 license: MPL-2.0 license-file: LICENSE author: Matthias Pall Gissurarson@@ -58,6 +58,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs+ other-modules: Properties default-language: Haskell2010 build-depends: base >=4.14 && <5
src/Database/DuckDB/Simple/LogicalRep.hs view
@@ -183,7 +183,11 @@ let fields = elems fieldArray count = length fields if count == 0- then c_duckdb_create_struct_type nullPtr nullPtr 0+ then+ withMany withCString [] \namePtrs ->+ withArray namePtrs \nameArray ->+ withArray [] \typeArray ->+ c_duckdb_create_struct_type typeArray nameArray 0 else do childTypes <- mapM (logicalTypeFromRep . structFieldValue) fields let names = map (Text.unpack . structFieldName) fields@@ -198,7 +202,11 @@ let members = elems memberArray count = length members if count == 0- then c_duckdb_create_union_type nullPtr nullPtr 0+ then+ withMany withCString [] \namePtrs ->+ withArray namePtrs \nameArray ->+ withArray [] \memberPtr ->+ c_duckdb_create_union_type memberPtr nameArray 0 else do memberTypes <- mapM (logicalTypeFromRep . unionMemberType) members let names = map (Text.unpack . unionMemberName) members
src/Database/DuckDB/Simple/ToField.hs view
@@ -411,15 +411,12 @@ bracket (createElementLogicalType (Proxy :: Proxy a)) destroyLogicalType \elementType -> do let elemsList = elems arr count = length elemsList- if count == 0- then c_duckdb_create_array_value elementType nullPtr 0- else do- values <- mapM toDuckValue elemsList- result <-- withArray values \ptr ->- c_duckdb_create_array_value elementType ptr (fromIntegral count)- mapM_ destroyValue values- pure result+ values <- mapM toDuckValue elemsList+ result <-+ withArray values \ptr ->+ c_duckdb_create_array_value elementType ptr (fromIntegral count)+ mapM_ destroyValue values+ pure result structValueDuckValue :: StructValue FieldValue -> IO DuckDBValue structValueDuckValue StructValue{structValueFields, structValueTypes, structValueIndex = _} = do@@ -643,7 +640,6 @@ pure DuckDBUHugeInt{duckDBUHugeIntLower = lower, duckDBUHugeIntUpper = upper} withDuckValues :: [DuckDBValue] -> (Ptr DuckDBValue -> IO a) -> IO a-withDuckValues [] action = action nullPtr withDuckValues xs action = withArray xs action typeMismatch :: String -> FieldValue -> IO a
+ test/Properties.hs view
@@ -0,0 +1,408 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Properties (roundTripTests) where++import Control.Monad (forM)+import Data.Array (Array, elems, listArray)+import qualified Data.ByteString as BS+import Data.Fixed (Fixed (MkFixed))+import Data.Int (Int16, Int32, Int64, Int8)+import qualified Data.Map.Strict as Map+import Data.Proxy (Proxy (..))+import qualified Data.Text as Text+import Data.Time.Calendar (Day (..))+import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, picosecondsToDiffTime)+import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..), timeOfDayToTime)+import Data.UUID (UUID)+import qualified Data.UUID as UUID+import Data.Word (Word16, Word32, Word64, Word8)+import Database.DuckDB.FFI (+ pattern DuckDBTypeBlob,+ pattern DuckDBTypeBoolean,+ pattern DuckDBTypeDouble,+ pattern DuckDBTypeInteger,+ pattern DuckDBTypeVarchar,+ )+import Database.DuckDB.Simple (Connection, close, open, query)+import Database.DuckDB.Simple.FromField (+ BigNum (..),+ BitString (..),+ FieldValue (..),+ FromField,+ LogicalTypeRep (..),+ StructField (..),+ StructValue (..),+ UnionMemberType (..),+ UnionValue (..)+ )+import Database.DuckDB.Simple.ToField (ToField)+import Database.DuckDB.Simple.Types (Null (..), Only (..))+import Numeric.Natural (Natural)+import Test.QuickCheck (+ Gen,+ Property,+ arbitrary,+ arbitrarySizedNatural,+ chooseInt,+ chooseInteger,+ counterexample,+ elements,+ frequency,+ forAllShrink,+ ioProperty,+ scale,+ shrink,+ shrinkIntegral,+ sized,+ suchThat,+ vectorOf,+ (===),+ )+import Test.Tasty (TestTree, testGroup, withResource)+import Test.Tasty.QuickCheck (testProperty)++data SomeRoundTrip+ = forall a.+ (Eq a, Show a, ToField a, FromField a) =>+ SomeRoundTrip String (Proxy a) (Gen a) (a -> [a])++roundTripTests :: TestTree+roundTripTests =+ withResource+ (open ":memory:")+ close+ \getConn ->+ testGroup+ "round-trip properties"+ (fmap (mkRoundTripTest getConn) specs)++mkRoundTripTest :: IO Connection -> SomeRoundTrip -> TestTree+mkRoundTripTest getConn (SomeRoundTrip label proxy gen shrinker) =+ testProperty label $+ forAllShrink gen shrinker (roundTripProperty getConn proxy)++roundTripProperty ::+ forall a.+ (Eq a, Show a, ToField a, FromField a) =>+ IO Connection ->+ Proxy a ->+ a ->+ Property+roundTripProperty getConn _ value =+ ioProperty do+ conn <- getConn+ rows <- query conn "SELECT ?" (Only value)+ case rows of+ [Only out] ->+ pure $+ counterexample+ ("expected " ++ show value ++ ", got " ++ show out)+ (out === value)+ other ->+ fail $+ "unexpected row count during round-trip: "+ ++ show (length other)++specs :: [SomeRoundTrip]+specs =+ [ SomeRoundTrip "Null" (Proxy :: Proxy Null) (pure Null) shrinkNone+ , SomeRoundTrip "Bool" (Proxy :: Proxy Bool) (arbitrary :: Gen Bool) shrink+ , SomeRoundTrip "Int" (Proxy :: Proxy Int) (arbitrary :: Gen Int) shrink+ , SomeRoundTrip "Int8" (Proxy :: Proxy Int8) (arbitrary :: Gen Int8) shrink+ , SomeRoundTrip "Int16" (Proxy :: Proxy Int16) (arbitrary :: Gen Int16) shrink+ , SomeRoundTrip "Int32" (Proxy :: Proxy Int32) (arbitrary :: Gen Int32) shrink+ , SomeRoundTrip "Int64" (Proxy :: Proxy Int64) (arbitrary :: Gen Int64) shrink+ , SomeRoundTrip "Integer" (Proxy :: Proxy Integer) (arbitrary :: Gen Integer) shrink+ , SomeRoundTrip "BigNum" (Proxy :: Proxy BigNum) genBigNum shrinkBigNum+ , SomeRoundTrip "Natural" (Proxy :: Proxy Natural) genNatural shrinkNatural+ , SomeRoundTrip "Word" (Proxy :: Proxy Word) (arbitrary :: Gen Word) shrink+ , SomeRoundTrip "Word8" (Proxy :: Proxy Word8) (arbitrary :: Gen Word8) shrink+ , SomeRoundTrip "Word16" (Proxy :: Proxy Word16) (arbitrary :: Gen Word16) shrink+ , SomeRoundTrip "Word32" (Proxy :: Proxy Word32) (arbitrary :: Gen Word32) shrink+ , SomeRoundTrip "Word64" (Proxy :: Proxy Word64) (arbitrary :: Gen Word64) shrink+ , SomeRoundTrip "Float" (Proxy :: Proxy Float) genFiniteFloat shrink+ , SomeRoundTrip "Double" (Proxy :: Proxy Double) genFiniteDouble shrink+ , SomeRoundTrip "String" (Proxy :: Proxy String) genStringNoNul shrinkStringNoNul+ , SomeRoundTrip "Text" (Proxy :: Proxy Text.Text) genTextNoNul shrinkTextNoNul+ , SomeRoundTrip "ByteString" (Proxy :: Proxy BS.ByteString) genByteString shrinkByteString+ , SomeRoundTrip "BitString" (Proxy :: Proxy BitString) genBitString shrinkBitString+ , SomeRoundTrip "UUID" (Proxy :: Proxy UUID) genUUID shrinkNone+ , SomeRoundTrip "Day" (Proxy :: Proxy Day) genDay shrinkDay+ , SomeRoundTrip "TimeOfDay" (Proxy :: Proxy TimeOfDay) genTimeOfDay shrinkTimeOfDay+ , SomeRoundTrip "LocalTime" (Proxy :: Proxy LocalTime) genLocalTime shrinkLocalTime+ , SomeRoundTrip "UTCTime" (Proxy :: Proxy UTCTime) genUTCTime shrinkUTCTime+ , SomeRoundTrip "Maybe Int" (Proxy :: Proxy (Maybe Int)) genMaybeInt shrinkMaybeInt+ , SomeRoundTrip "Array Int Int" (Proxy :: Proxy (Array Int Int)) genIntArray shrinkIntArray+ , SomeRoundTrip "StructValue FieldValue" (Proxy :: Proxy (StructValue FieldValue)) genStructValue shrinkStructValue+ , SomeRoundTrip "UnionValue FieldValue" (Proxy :: Proxy (UnionValue FieldValue)) genUnionValue shrinkNone+ ]++shrinkNone :: a -> [a]+shrinkNone _ = []++genNatural :: Gen Natural+genNatural = fromInteger <$> arbitrarySizedNatural++shrinkNatural :: Natural -> [Natural]+shrinkNatural n = fromInteger <$> shrinkIntegral (toInteger n)++genBigNum :: Gen BigNum+genBigNum = BigNum <$> scale (\s -> s * 8) (arbitrary :: Gen Integer)++shrinkBigNum :: BigNum -> [BigNum]+shrinkBigNum (BigNum n) = BigNum <$> shrinkIntegral n++genFiniteFloat :: Gen Float+genFiniteFloat =+ (arbitrary :: Gen Float)+ `suchThat` \x -> not (isNaN x || isInfinite x)++genFiniteDouble :: Gen Double+genFiniteDouble =+ (arbitrary :: Gen Double)+ `suchThat` \x -> not (isNaN x || isInfinite x)++genStringNoNul :: Gen String+genStringNoNul =+ sized \n -> do+ len <- chooseInt (0, max 0 (min n 32))+ vectorOf len genCharNoNul++shrinkStringNoNul :: String -> [String]+shrinkStringNoNul =+ filter (all (/= '\0')) . shrink++genCharNoNul :: Gen Char+genCharNoNul =+ (arbitrary :: Gen Char) `suchThat` (/= '\0')++genTextNoNul :: Gen Text.Text+genTextNoNul = Text.pack <$> genStringNoNul++shrinkTextNoNul :: Text.Text -> [Text.Text]+shrinkTextNoNul txt = Text.pack <$> shrinkStringNoNul (Text.unpack txt)++genByteString :: Gen BS.ByteString+genByteString =+ sized \n -> do+ len <- chooseInt (0, max 0 (min n 64))+ BS.pack <$> vectorOf len (arbitrary :: Gen Word8)++shrinkByteString :: BS.ByteString -> [BS.ByteString]+shrinkByteString bs =+ [ BS.pack xs+ | xs <- shrink (BS.unpack bs)+ , length xs <= 64+ ]++genBitString :: Gen BitString+genBitString =+ sized \n -> do+ len <- chooseInt (1, max 1 (min 64 (n * 2)))+ bytes <- vectorOf len (arbitrary :: Gen Word8)+ pure (BitString 0 (BS.pack bytes))++shrinkBitString :: BitString -> [BitString]+shrinkBitString (BitString _ raw) =+ [ BitString 0 (BS.pack xs)+ | xs <- shrink (BS.unpack raw)+ , length xs <= 64+ , not (null xs)+ ]++genUUID :: Gen UUID+genUUID =+ UUID.fromWords+ <$> (arbitrary :: Gen Word32)+ <*> (arbitrary :: Gen Word32)+ <*> (arbitrary :: Gen Word32)+ <*> (arbitrary :: Gen Word32)++genMaybeInt :: Gen (Maybe Int)+genMaybeInt =+ sized \n ->+ let bound = max 1 (min 1000 (n * 10))+ in frequency+ [ (1, pure Nothing)+ , (3, Just <$> chooseInt (-bound, bound))+ ]++shrinkMaybeInt :: Maybe Int -> [Maybe Int]+shrinkMaybeInt Nothing = []+shrinkMaybeInt (Just x) = Nothing : [Just y | y <- shrink x]++genDay :: Gen Day+genDay = ModifiedJulianDay <$> (arbitrary :: Gen Integer)++shrinkDay :: Day -> [Day]+shrinkDay (ModifiedJulianDay d) = ModifiedJulianDay <$> shrink d++genTimeOfDay :: Gen TimeOfDay+genTimeOfDay = do+ micros <- chooseInteger (0, 86400 * 1000000 - 1)+ pure (microsecondsToTimeOfDay micros)++shrinkTimeOfDay :: TimeOfDay -> [TimeOfDay]+shrinkTimeOfDay tod =+ [ microsecondsToTimeOfDay us+ | us <- shrinkIntegral (timeOfDayToMicroseconds tod)+ , us >= 0+ ]++genLocalTime :: Gen LocalTime+genLocalTime = LocalTime <$> genDay <*> genTimeOfDay++shrinkLocalTime :: LocalTime -> [LocalTime]+shrinkLocalTime LocalTime{localDay, localTimeOfDay} =+ [ LocalTime day' localTimeOfDay+ | day' <- shrinkDay localDay+ ]+ ++ [ LocalTime localDay time'+ | time' <- shrinkTimeOfDay localTimeOfDay+ ]++genUTCTime :: Gen UTCTime+genUTCTime = do+ day <- genDay+ micros <- chooseInteger (0, 86400 * 1000000 - 1)+ pure (UTCTime day (picosecondsToDiffTime (micros * 1000000)))++shrinkUTCTime :: UTCTime -> [UTCTime]+shrinkUTCTime (UTCTime day diff) =+ [UTCTime day' diff | day' <- shrinkDay day]+ ++ [UTCTime day diff' | diff' <- shrinkDiff diff]+ where+ shrinkDiff dt =+ [ picosecondsToDiffTime ps+ | ps <- shrinkIntegral (diffTimeToPicoseconds dt)+ , ps >= 0+ , ps `mod` 1000000 == 0+ ]++genIntArray :: Gen (Array Int Int)+genIntArray =+ sized \n -> do+ size <- chooseInt (0, max 0 (min n 8))+ values <- vectorOf size (arbitrary :: Gen Int)+ pure $+ if size == 0+ then listArray (1, 0) []+ else listArray (0, size - 1) values++shrinkIntArray :: Array Int Int -> [Array Int Int]+shrinkIntArray arr =+ let values = elems arr+ in [ listArray (0, length xs - 1) xs+ | xs <- shrink values+ , not (null xs)+ ]+ ++ if null values then [] else [listArray (1, 0) []]++genStructValue :: Gen (StructValue FieldValue)+genStructValue = do+ count <- chooseInt (0, 3)+ if count == 0+ then pure emptyStruct+ else do+ types <- vectorOf count genSimpleType+ values <- forM types simpleTypeValue+ let names = [Text.pack ("field" ++ show i) | i <- [0 .. count - 1]]+ fieldArr =+ listArray+ (0, count - 1)+ [ StructField{structFieldName = name, structFieldValue = val}+ | (name, val) <- zip names values+ ]+ typeArr =+ listArray+ (0, count - 1)+ [ StructField{structFieldName = name, structFieldValue = simpleTypeRep ty}+ | (name, ty) <- zip names types+ ]+ indexMap = Map.fromList (zip names [0 ..])+ pure+ StructValue+ { structValueFields = fieldArr+ , structValueTypes = typeArr+ , structValueIndex = indexMap+ }++shrinkStructValue :: StructValue FieldValue -> [StructValue FieldValue]+shrinkStructValue StructValue{structValueFields}+ | null (elems structValueFields) = []+ | otherwise = [emptyStruct]++genUnionValue :: Gen (UnionValue FieldValue)+genUnionValue = do+ memberCount <- chooseInt (1, 4)+ types <- vectorOf memberCount genSimpleType+ let names = [Text.pack ("alt" ++ show i) | i <- [0 .. memberCount - 1]]+ members =+ listArray+ (0, memberCount - 1)+ [ UnionMemberType{unionMemberName = name, unionMemberType = simpleTypeRep ty}+ | (name, ty) <- zip names types+ ]+ tag <- chooseInt (0, memberCount - 1)+ payload <- simpleTypeValue (types !! tag)+ pure+ UnionValue+ { unionValueIndex = fromIntegral tag+ , unionValueLabel = names !! tag+ , unionValuePayload = payload+ , unionValueMembers = members+ }++emptyStruct :: StructValue FieldValue+emptyStruct =+ StructValue+ { structValueFields = listArray (1, 0) []+ , structValueTypes = listArray (1, 0) []+ , structValueIndex = Map.empty+ }++data SimpleType+ = SimpleBool+ | SimpleInt32+ | SimpleDouble+ | SimpleText+ | SimpleBlob+ deriving (Eq, Show)++genSimpleType :: Gen SimpleType+genSimpleType =+ elements [SimpleBool, SimpleInt32, SimpleDouble, SimpleText, SimpleBlob]++simpleTypeRep :: SimpleType -> LogicalTypeRep+simpleTypeRep = \case+ SimpleBool -> LogicalTypeScalar DuckDBTypeBoolean+ SimpleInt32 -> LogicalTypeScalar DuckDBTypeInteger+ SimpleDouble -> LogicalTypeScalar DuckDBTypeDouble+ SimpleText -> LogicalTypeScalar DuckDBTypeVarchar+ SimpleBlob -> LogicalTypeScalar DuckDBTypeBlob++simpleTypeValue :: SimpleType -> Gen FieldValue+simpleTypeValue = \case+ SimpleBool -> FieldBool <$> (arbitrary :: Gen Bool)+ SimpleInt32 -> FieldInt32 <$> (arbitrary :: Gen Int32)+ SimpleDouble -> FieldDouble <$> genFiniteDouble+ SimpleText -> FieldText <$> genTextNoNul+ SimpleBlob -> FieldBlob <$> genByteString++timeOfDayToMicroseconds :: TimeOfDay -> Integer+timeOfDayToMicroseconds tod =+ diffTimeToPicoseconds (timeOfDayToTime tod) `div` 1000000++microsecondsToTimeOfDay :: Integer -> TimeOfDay+microsecondsToTimeOfDay micros =+ let (hours, remHour) = micros `divMod` (3600 * 1000000)+ (minutes, remMinute) = remHour `divMod` (60 * 1000000)+ (seconds, fracMicros) = remMinute `divMod` 1000000+ pico = seconds * 1000000000000 + fracMicros * 1000000+ in TimeOfDay (fromInteger hours) (fromInteger minutes) (MkFixed pico)
test/Spec.hs view
@@ -62,6 +62,7 @@ , ViaDuckDB (..) ) import Database.DuckDB.Simple.Ok (Ok (..))+import Properties (roundTripTests) import GHC.Generics (Generic) import Numeric.Natural (Natural) import Test.Tasty (TestTree, defaultMain, testGroup)@@ -184,6 +185,7 @@ [ connectionTests , withConnectionTests , statementTests+ , roundTripTests , typeTests , streamingTests , functionsTests