duckdb-simple 0.1.2.0 → 0.1.2.1

raw patch · 11 files changed

+2629/−1053 lines, 11 filesdep +arrayPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: array

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• README.md +118/−5
• duckdb-simple.cabal +8/−1
• src/Database/DuckDB/Simple.hs +19/−472
• src/Database/DuckDB/Simple/FromField.hs +55/−1
• src/Database/DuckDB/Simple/Function.hs +7/−327
• src/Database/DuckDB/Simple/Generic.hs +724/−0
• src/Database/DuckDB/Simple/LogicalRep.hs +235/−0
• src/Database/DuckDB/Simple/Materialize.hs +582/−0
• src/Database/DuckDB/Simple/ToField.hs +594/−218
• test/Spec.hs +280/−29

@@ -1,5 +1,12 @@ # Changelog +## Unreleased+- 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.+- Documented struct/union generic support; added richer tests covering database round-trips and deriving-via examples.+- Support decoding and binding STRUCT and UNION values via new `StructValue`/`UnionValue` helpers and corresponding `FromField`/`ToField` instances.+ ## 0.1.2.0 - Added LIST/MAP coverage note: LIST columns decode into Haskell lists and MAP columns into strict `Map k v`, with matching parameter bindings via `ToField`. - Taught `FromField` to interpret `FieldBigNum` as `Integer`/`Natural` and added matching `ToField` instances for `BigNum`, `Integer`, and `Natural` so BIGNUM parameters round-trip without truncation.

@@ -33,6 +33,11 @@   preparing positional or named parameters. - `Database.DuckDB.Simple.FromField` / `FromRow` – typeclasses for decoding   query results, with generic deriving support for product types.+- `Database.DuckDB.Simple.Generic` – automatic encoding/decoding of Haskell+  ADTs as DuckDB STRUCTs and UNIONs via GHC generics and the `ViaDuckDB`+  deriving-via helper.+- `Database.DuckDB.Simple.LogicalRep` – structured value types (`StructValue`,+  `UnionValue`) for working with DuckDB's composite types. - `Database.DuckDB.Simple.Types` – shared types (`Query`, `Null`, `Only`,   `(:.)`, `SQLError`). - `Database.DuckDB.Simple.Function` – register scalar Haskell functions that@@ -63,7 +68,7 @@  ```haskell import Database.DuckDB.Simple-import Database.DuckDB.Simple (NamedParam ((:=)))+import Database.DuckDB.Simple.ToField (NamedParam ((:=)))  insertNamed :: Connection -> IO Int insertNamed conn =@@ -107,6 +112,109 @@ Helper combinators such as `field`, `fieldWith`, and `numFieldsRemaining` are available when a custom instance needs fine-grained control. +## Generic Encoding with ViaDuckDB++The `Database.DuckDB.Simple.Generic` module provides automatic encoding and+decoding of Haskell algebraic data types as DuckDB STRUCTs and UNIONs via+GHC generics.++### Product Types as STRUCTs++Product types (records) are automatically encoded as DuckDB STRUCT values:++```haskell+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}++import Data.Int (Int64)+import Data.Text (Text)+import Database.DuckDB.Simple+import Database.DuckDB.Simple.Generic (ViaDuckDB (..))+import GHC.Generics (Generic)++data User = User+  { userId :: Int64+  , userName :: Text+  }+  deriving stock (Eq, Show, Generic)+  deriving (DuckDBColumnType, ToField, FromField) via (ViaDuckDB User)++-- Round-trip through the database+storeAndFetchUser :: Connection -> User -> IO [User]+storeAndFetchUser conn user = do+  _ <- execute_ conn "CREATE TABLE users (data STRUCT(userId BIGINT, userName TEXT))"+  _ <- execute conn "INSERT INTO users VALUES (?)" (Only user)+  fmap fromOnly <$> query_ conn "SELECT data FROM users"+```++### Sum Types as UNIONs++Sum types are encoded as DuckDB UNION values, with each constructor becoming a+union member:++```haskell+data Shape+  = Circle Double+  | Rectangle Double Double+  | Point+  deriving stock (Eq, Show, Generic)+  deriving (DuckDBColumnType, ToField, FromField) via (ViaDuckDB Shape)++-- Store and retrieve shape data+storeShape :: Connection -> Shape -> IO [Shape]+storeShape conn shape = do+  _ <- execute_ conn+    "CREATE TABLE shapes (s UNION(Circle STRUCT(field1 DOUBLE), \+    \Rectangle STRUCT(field1 DOUBLE, field2 DOUBLE), Point STRUCT()))"+  _ <- execute conn "INSERT INTO shapes VALUES (?)" (Only shape)+  fmap fromOnly <$> query_ conn "SELECT s FROM shapes"+```++Nullary constructors (like `Point`) are encoded with a null payload.+Non-record constructors use positional field names (`field1`, `field2`, etc.).++### Arrays and Lists++DuckDB arrays (fixed-length) and lists (variable-length) are also supported:++```haskell+import Data.Array (Array, listArray)++storeArray :: Connection -> IO [Array Int Int]+storeArray conn = do+  _ <- execute_ conn "CREATE TABLE arrays (vals INTEGER[3])"+  let arr = listArray (0, 2) [1, 2, 3]+  _ <- execute conn "INSERT INTO arrays VALUES (?)" (Only arr)+  fmap fromOnly <$> query_ conn "SELECT vals FROM arrays"++storeList :: Connection -> IO [[Int]]+storeList conn = do+  _ <- execute_ conn "CREATE TABLE lists (vals INTEGER[])"+  _ <- execute conn "INSERT INTO lists VALUES (?)" (Only [1, 2, 3])+  fmap fromOnly <$> query_ conn "SELECT vals FROM lists"+```++### Manual STRUCT and UNION Handling++For more control, you can work directly with `StructValue` and `UnionValue`+from `Database.DuckDB.Simple.LogicalRep`:++```haskell+import Database.DuckDB.Simple.LogicalRep (StructValue (..), UnionValue (..))+import Database.DuckDB.Simple.FromField (FieldValue (..))++manualStruct :: Connection -> IO [(StructValue FieldValue, UnionValue FieldValue)]+manualStruct conn = do+  _ <- execute_ conn+    "CREATE TABLE composite (s STRUCT(a INT, b INT), \+    \u UNION(x INT, y VARCHAR))"+  [(s, u)] <- query_ conn+    "SELECT {'a': 1, 'b': 2}, \+    \CAST(union_value(x := 42) AS UNION(x INT, y VARCHAR))"+  _ <- execute conn "INSERT INTO composite VALUES (?, ?)" (s, u)+  query_ conn "SELECT s, u FROM composite"+```+ ### Resource Management  - `withConnection` and `withStatement` wrap the open/close lifecycle and guard@@ -150,11 +258,16 @@   result processing. - Comprehensive scalar type support: signed/unsigned integers, HUGEINT/UHUGEINT,   decimals (with width/scale), intervals, precise and timezone-aware temporals,-  enums, bit strings, blobs, and bignums.+  enums, bit strings, blobs, bignums, and UUIDs.+- Composite types: STRUCTs, UNIONs, LISTs, fixed-length ARRAYs, and MAPs with+  full encoding/decoding support.+- Generic encoding/decoding: automatic STRUCT/UNION mapping for Haskell ADTs via+  GHC generics and the `ViaDuckDB` deriving-via helper. - Row decoding via `FromField`/`FromRow`, with generic deriving for product types.-- User-defined scalar functions backed by Haskell functions.-- Transaction helpers (`withTransaction`, `withSavepoint` fallback) and metadata-  accessors (`columnCount`, `columnName`, `rowsChanged`).+- User-defined scalar functions backed by Haskell functions (including IO and+  nullable arguments).+- Transaction helpers (`withTransaction`) and metadata accessors (`columnCount`,+  `columnName`, `rowsChanged`).  ## User-Defined Functions 

@@ -1,6 +1,6 @@ cabal-version:      3.4 name:               duckdb-simple-version:            0.1.2.0+version:            0.1.2.1 license:            MPL-2.0 license-file:       LICENSE author:             Matthias Pall Gissurarson@@ -33,10 +33,14 @@       Database.DuckDB.Simple.FromField       Database.DuckDB.Simple.FromRow       Database.DuckDB.Simple.Internal+      Database.DuckDB.Simple.LogicalRep+      Database.DuckDB.Simple.Generic       Database.DuckDB.Simple.Ok       Database.DuckDB.Simple.ToField       Database.DuckDB.Simple.ToRow       Database.DuckDB.Simple.Types+  other-modules:+      Database.DuckDB.Simple.Materialize   hs-source-dirs:   src   default-language: Haskell2010   build-depends:@@ -48,6 +52,7 @@     , transformers >= 0.6 && <0.7     , uuid >=1.3 && <1.4     , time >= 1.12 && <1.13+    , array >= 0.5 && <0.6  test-suite duckdb-simple-test   type:             exitcode-stdio-1.0@@ -67,3 +72,5 @@     , QuickCheck >=2.14 && <2.15     , uuid >=1.3 && <1.4     , time+    , array >= 0.5 && <0.6+    , duckdb-ffi >= 1.4.1.2 && <1.5

@@ -78,39 +78,16 @@ import Control.Monad (forM, join, void, when, zipWithM, zipWithM_) import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef, writeIORef) import Control.Exception (SomeException, bracket, finally, mask, onException, throwIO, try)-import qualified Data.ByteString as BS-import Data.Bits ((.|.), shiftL, Bits (..))-import Data.Int (Int16, Int32, Int64, Int8) import Data.Maybe (isJust, isNothing) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Foreign as TextForeign-import qualified Data.Text.Encoding as TextEncoding-import Data.Time.Calendar (Day, fromGregorian)-import Data.Time.Clock (UTCTime (..))-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-import Data.Time.LocalTime-    ( LocalTime (..)-    , TimeOfDay (..)-    , minutesToTimeZone-    , utcToLocalTime-    , utc-    )-import Data.Word (Word16, Word32, Word64, Word8)-import Data.Ratio ((%)) import Database.DuckDB.FFI import Database.DuckDB.Simple.FromField-    ( BigNum (..)-    , BitString (..)-    , DecimalValue (..)-    , Field (..)-    , FieldValue (..)+    ( Field (..)     , FieldParser     , FromField (..)-    , IntervalValue (..)     , ResultError (..)-    , TimeWithZone (..)-    , fromBigNumBytes     ) import Database.DuckDB.Simple.FromRow     ( FromRow (..)@@ -122,6 +99,8 @@     , rowErrorsToSqlError     ) import Database.DuckDB.Simple.Function (Function, createFunction, deleteFunction)+import Database.DuckDB.Simple.Materialize+    ( materializeValue ) import Database.DuckDB.Simple.Internal     ( Connection (..)     , ConnectionState (..)@@ -142,12 +121,10 @@ import Database.DuckDB.Simple.ToRow (ToRow (..)) import Database.DuckDB.Simple.Types (FormatError (..), Null (..), Only (..), (:.) (..)) import Foreign.C.String (CString, peekCString, withCString)-import Foreign.C.Types (CBool (..)) import Foreign.Marshal.Alloc (alloca, free, malloc)-import Foreign.Ptr (Ptr, castPtr, nullPtr, plusPtr)-import Foreign.Storable (Storable (..), peekElemOff, peekByteOff, pokeByteOff)+import Foreign.Ptr (Ptr, castPtr, nullPtr)+import Foreign.Storable (peek, poke) import Database.DuckDB.Simple.Ok (Ok(..))-import qualified Data.UUID as UUID  -- | Open a DuckDB database located at the supplied path. open :: FilePath -> IO Connection@@ -643,74 +620,20 @@  buildField :: Query -> Int -> StatementStreamColumn -> StatementStreamChunkVector -> IO Field buildField queryText rowIdx column StatementStreamChunkVector{statementStreamChunkVectorHandle, statementStreamChunkVectorData, statementStreamChunkVectorValidity} = do-    let duckIdx = fromIntegral rowIdx-        dtype = statementStreamColumnType column-    valid <- chunkIsRowValid statementStreamChunkVectorValidity duckIdx+    let dtype = statementStreamColumnType column     value <--        if not valid-            then pure FieldNull-            else case dtype of-                DuckDBTypeBoolean -> do-                    raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr Word8) rowIdx-                    pure (FieldBool (raw /= 0))-                DuckDBTypeTinyInt -> do-                    raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr Int8) rowIdx-                    pure (FieldInt8 (fromIntegral raw))-                DuckDBTypeSmallInt -> do-                    raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr Int16) rowIdx-                    pure (FieldInt16 (fromIntegral raw))-                DuckDBTypeInteger -> do-                    raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr Int32) rowIdx-                    pure (FieldInt32 (fromIntegral raw))-                DuckDBTypeBigInt -> do-                    raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr Int64) rowIdx-                    pure (FieldInt64 raw)-                DuckDBTypeUTinyInt -> do-                    raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr Word8) rowIdx-                    pure (FieldWord8 (fromIntegral raw))-                DuckDBTypeUSmallInt -> do-                    raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr Word16) rowIdx-                    pure (FieldWord16 (fromIntegral raw))-                DuckDBTypeUInteger -> do-                    raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr Word32) rowIdx-                    pure (FieldWord32 (fromIntegral raw))-                DuckDBTypeUBigInt -> do-                    raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr Word64) rowIdx-                    pure (FieldWord64 (fromIntegral raw))-                DuckDBTypeBlob -> do-                    blob <- chunkDecodeBlob statementStreamChunkVectorData duckIdx-                    pure (FieldBlob blob)-                DuckDBTypeDate -> do-                    raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr Int32) rowIdx-                    day <- decodeDuckDBDate (DuckDBDate raw)-                    pure (FieldDate day)-                DuckDBTypeTime -> do-                    raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr DuckDBTime) rowIdx-                    tod <- decodeDuckDBTime raw-                    pure (FieldTime tod)-                DuckDBTypeTimestamp -> do-                    raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr DuckDBTimestamp) rowIdx-                    ts <- decodeDuckDBTimestamp raw-                    pure (FieldTimestamp ts)-                DuckDBTypeFloat -> do-                    raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr Float) rowIdx-                    pure (FieldDouble (realToFrac raw))-                DuckDBTypeDouble -> do-                    raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr Double) rowIdx-                    pure (FieldDouble raw)-                DuckDBTypeVarchar -> FieldText <$> chunkDecodeText statementStreamChunkVectorData duckIdx-                DuckDBTypeList -> FieldList <$> decodeListElements statementStreamChunkVectorHandle statementStreamChunkVectorData rowIdx-                DuckDBTypeMap -> FieldMap <$> decodeMapPairs statementStreamChunkVectorHandle statementStreamChunkVectorData rowIdx-                DuckDBTypeStruct -> error "duckdb-simple: STRUCT columns are not supported"-                DuckDBTypeUnion -> error "duckdb-simple: UNION columns are not supported"-                DuckDBTypeHugeInt -> do-                    raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr DuckDBHugeInt) rowIdx-                    pure (FieldHugeInt (duckDBHugeIntToInteger raw))-                DuckDBTypeUHugeInt -> do-                    raw <- peekElemOff (castPtr statementStreamChunkVectorData :: Ptr DuckDBUHugeInt) rowIdx-                    pure (FieldUHugeInt (duckDBUHugeIntToInteger raw))-                _ ->-                    throwIO (streamingUnsupportedTypeError queryText column)+        case dtype of+            DuckDBTypeStruct ->+                throwIO (streamingUnsupportedTypeError queryText column)+            DuckDBTypeUnion ->+                throwIO (streamingUnsupportedTypeError queryText column)+            _ ->+                materializeValue+                    dtype+                    statementStreamChunkVectorHandle+                    statementStreamChunkVectorData+                    statementStreamChunkVectorValidity+                    rowIdx     pure         Field             { fieldName = statementStreamColumnName column@@ -718,41 +641,6 @@             , fieldValue = value             } -chunkIsRowValid :: Ptr Word64 -> DuckDBIdx -> IO Bool-chunkIsRowValid validity rowIdx-    | validity == nullPtr = pure True-    | otherwise = do-        CBool flag <- c_duckdb_validity_row_is_valid validity rowIdx-        pure (flag /= 0)--chunkDecodeText :: Ptr () -> DuckDBIdx -> IO Text-chunkDecodeText dataPtr rowIdx = do-    let base = castPtr dataPtr :: Ptr Word8-        offset = fromIntegral rowIdx * duckdbStringTSize-        stringPtr = castPtr (base `plusPtr` offset) :: Ptr DuckDBStringT-    len <- c_duckdb_string_t_length stringPtr-    if len == 0-        then pure Text.empty-        else do-            cstr <- c_duckdb_string_t_data stringPtr-            bytes <- BS.packCStringLen (cstr, fromIntegral len)-            pure (TextEncoding.decodeUtf8 bytes)--chunkDecodeBlob :: Ptr () -> DuckDBIdx -> IO BS.ByteString-chunkDecodeBlob dataPtr rowIdx = do-    let base = castPtr dataPtr :: Ptr Word8-        offset = fromIntegral rowIdx * duckdbStringTSize-        stringPtr = castPtr (base `plusPtr` offset) :: Ptr DuckDBStringT-    len <- c_duckdb_string_t_length stringPtr-    if len == 0-        then pure BS.empty-        else do-            ptr <- c_duckdb_string_t_data stringPtr-            BS.packCStringLen (ptr, fromIntegral len)--duckdbStringTSize :: Int-duckdbStringTSize = 16- cleanupStatementStreamRef :: IORef StatementStreamState -> IO () cleanupStatementStreamRef ref = do     state <- atomicModifyIORef' ref (StatementStreamIdle,)@@ -888,11 +776,6 @@ destroyPrepared stmt =     alloca \ptr -> poke ptr stmt >> c_duckdb_destroy_prepare ptr -destroyLogicalType :: DuckDBLogicalType -> IO ()-destroyLogicalType logicalType =-    alloca \ptr -> do-        poke ptr logicalType-        c_duckdb_destroy_logical_type ptr  fetchPrepareError :: DuckDBPreparedStatement -> IO Text fetchPrepareError stmt = do@@ -1078,7 +961,7 @@ buildMaterializedField :: Int -> StatementStreamColumn -> StatementStreamChunkVector -> IO Field buildMaterializedField rowIdx column StatementStreamChunkVector{statementStreamChunkVectorHandle, statementStreamChunkVectorData, statementStreamChunkVectorValidity} = do     value <--        materializedValueFromPointers+        materializeValue             (statementStreamColumnType column)             statementStreamChunkVectorHandle             statementStreamChunkVectorData@@ -1090,342 +973,6 @@             , fieldIndex = statementStreamColumnIndex column             , fieldValue = value             }--data DuckDBListEntry = DuckDBListEntry-    { duckDBListEntryOffset :: !Word64-    , duckDBListEntryLength :: !Word64-    }-    deriving (Eq, Show)--instance Storable DuckDBListEntry where-    sizeOf _ = listEntryWordSize * 2-    alignment _ = alignment (0 :: Word64)-    peek ptr = do-        offset <- peekByteOff ptr 0-        len <- peekByteOff ptr listEntryWordSize-        pure DuckDBListEntry{duckDBListEntryOffset = offset, duckDBListEntryLength = len}-    poke ptr DuckDBListEntry{duckDBListEntryOffset, duckDBListEntryLength} = do-        pokeByteOff ptr 0 duckDBListEntryOffset-        pokeByteOff ptr listEntryWordSize duckDBListEntryLength--listEntryWordSize :: Int-listEntryWordSize = sizeOf (0 :: Word64)--decodeListElements :: DuckDBVector -> Ptr () -> Int -> IO [FieldValue]-decodeListElements vector dataPtr rowIdx = do-    entry <- peekElemOff (castPtr dataPtr :: Ptr DuckDBListEntry) rowIdx-    (baseIdx, len) <- listEntryBounds (Text.pack "list") entry-    childVec <- c_duckdb_list_vector_get_child vector-    when (childVec == nullPtr) $-        throwIO (userError "duckdb-simple: list child vector is null")-    childType <- vectorElementType childVec-    childData <- c_duckdb_vector_get_data childVec-    childValidity <- c_duckdb_vector_get_validity childVec-    forM [0 .. len - 1] \delta ->-        materializedValueFromPointers childType childVec childData childValidity (baseIdx + delta)--decodeMapPairs :: DuckDBVector -> Ptr () -> Int -> IO [(FieldValue, FieldValue)]-decodeMapPairs vector dataPtr rowIdx = do-    entry <- peekElemOff (castPtr dataPtr :: Ptr DuckDBListEntry) rowIdx-    (baseIdx, len) <- listEntryBounds (Text.pack "map") entry-    structVec <- c_duckdb_list_vector_get_child vector-    when (structVec == nullPtr) $-        throwIO (userError "duckdb-simple: map struct vector is null")-    keyVec <- c_duckdb_struct_vector_get_child structVec 0-    valueVec <- c_duckdb_struct_vector_get_child structVec 1-    when (keyVec == nullPtr || valueVec == nullPtr) $-        throwIO (userError "duckdb-simple: map child vectors are null")-    keyType <- vectorElementType keyVec-    valueType <- vectorElementType valueVec-    keyData <- c_duckdb_vector_get_data keyVec-    valueData <- c_duckdb_vector_get_data valueVec-    keyValidity <- c_duckdb_vector_get_validity keyVec-    valueValidity <- c_duckdb_vector_get_validity valueVec-    forM [0 .. len - 1] \delta -> do-        let childIdx = baseIdx + delta-        keyValue <- materializedValueFromPointers keyType keyVec keyData keyValidity childIdx-        valueValue <- materializedValueFromPointers valueType valueVec valueData valueValidity childIdx-        pure (keyValue, valueValue)--vectorElementType :: DuckDBVector -> IO DuckDBType-vectorElementType vec = do-    logical <- c_duckdb_vector_get_column_type vec-    dtype <- c_duckdb_get_type_id logical-    destroyLogicalType logical-    pure dtype--listEntryBounds :: Text -> DuckDBListEntry -> IO (Int, Int)-listEntryBounds context DuckDBListEntry{duckDBListEntryOffset, duckDBListEntryLength} = do-    base <- ensureWithinIntRange (context <> Text.pack " offset") duckDBListEntryOffset-    len <- ensureWithinIntRange (context <> Text.pack " length") duckDBListEntryLength-    let maxInt = toInteger (maxBound :: Int)-        upperBound = toInteger base + toInteger len - 1-    when (len > 0 && upperBound > maxInt) $-        throwIO (userError ("duckdb-simple: " <> Text.unpack context <> " bounds exceed Int range"))-    pure (base, len)--ensureWithinIntRange :: Text -> Word64 -> IO Int-ensureWithinIntRange context value =-    let actual = toInteger value-        limit = toInteger (maxBound :: Int)-     in if actual <= limit-            then pure (fromInteger actual)-            else throwIO (userError ("duckdb-simple: " <> Text.unpack context <> " exceeds Int range"))--materializedValueFromPointers :: DuckDBType -> DuckDBVector -> Ptr () -> Ptr Word64 -> Int -> IO FieldValue-materializedValueFromPointers dtype vector dataPtr validity rowIdx = do-    let duckIdx = fromIntegral rowIdx :: DuckDBIdx-    valid <- chunkIsRowValid validity duckIdx-    if not valid-        then pure FieldNull-        else do-            case dtype of-                DuckDBTypeBoolean -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr Word8) rowIdx-                    pure (FieldBool (raw /= 0))-                DuckDBTypeTinyInt -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr Int8) rowIdx-                    pure (FieldInt8 raw)-                DuckDBTypeSmallInt -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr Int16) rowIdx-                    pure (FieldInt16 raw)-                DuckDBTypeInteger -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr Int32) rowIdx-                    pure (FieldInt32 raw)-                DuckDBTypeBigInt -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr Int64) rowIdx-                    pure (FieldInt64 raw)-                DuckDBTypeUTinyInt -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr Word8) rowIdx-                    pure (FieldWord8 raw)-                DuckDBTypeUSmallInt -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr Word16) rowIdx-                    pure (FieldWord16 raw)-                DuckDBTypeUInteger -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr Word32) rowIdx-                    pure (FieldWord32 raw)-                DuckDBTypeUBigInt -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr Word64) rowIdx-                    pure (FieldWord64 raw)-                DuckDBTypeFloat -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr Float) rowIdx-                    pure (FieldFloat raw)-                DuckDBTypeDouble -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr Double) rowIdx-                    pure (FieldDouble raw)-                DuckDBTypeVarchar -> FieldText <$> chunkDecodeText dataPtr duckIdx-                DuckDBTypeUUID -> do-                    DuckDBUHugeInt lower upper_biased <--                      peekElemOff (castPtr dataPtr :: Ptr DuckDBUHugeInt) rowIdx-                    let upper = upper_biased `xor` (0x8000000000000000 :: Word64)-                    return $ FieldUUID $ UUID.fromWords64 (fromIntegral upper) lower-                DuckDBTypeBlob -> FieldBlob <$> chunkDecodeBlob dataPtr duckIdx-                DuckDBTypeDate -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr Int32) rowIdx-                    FieldDate <$> decodeDuckDBDate (DuckDBDate raw)-                DuckDBTypeTime -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTime) rowIdx-                    FieldTime <$> decodeDuckDBTime raw-                DuckDBTypeTimeNs -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimeNs) rowIdx-                    pure (FieldTime (decodeDuckDBTimeNs raw))-                DuckDBTypeTimeTz -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimeTz) rowIdx-                    FieldTimeTZ <$> decodeDuckDBTimeTz raw-                DuckDBTypeTimestamp -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestamp) rowIdx-                    FieldTimestamp <$> decodeDuckDBTimestamp raw-                DuckDBTypeTimestampS -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestampS) rowIdx-                    FieldTimestamp <$> decodeDuckDBTimestampSeconds raw-                DuckDBTypeTimestampMs -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestampMs) rowIdx-                    FieldTimestamp <$> decodeDuckDBTimestampMilliseconds raw-                DuckDBTypeTimestampNs -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestampNs) rowIdx-                    FieldTimestamp <$> decodeDuckDBTimestampNanoseconds raw-                DuckDBTypeTimestampTz -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestamp) rowIdx-                    FieldTimestampTZ <$> decodeDuckDBTimestampUTCTime raw-                DuckDBTypeInterval -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBInterval) rowIdx-                    pure (FieldInterval (intervalValueFromDuckDB raw))-                DuckDBTypeDecimal -> do-                    bracket (c_duckdb_vector_get_column_type vector)-                            (\lty -> alloca $ \ptr -> poke ptr lty >> c_duckdb_destroy_logical_type ptr) $-                              \logical -> do-                                 width <- c_duckdb_decimal_width logical-                                 scale <- c_duckdb_decimal_scale logical-                                 internal_ty <- c_duckdb_decimal_internal_type logical-                                 raw <- case internal_ty of-                                     DuckDBTypeSmallInt ->-                                         toInteger <$> peekElemOff (castPtr dataPtr :: Ptr Int16) rowIdx-                                     DuckDBTypeInteger ->-                                         toInteger <$> peekElemOff (castPtr dataPtr :: Ptr Int32) rowIdx-                                     DuckDBTypeBigInt ->-                                         toInteger <$> peekElemOff (castPtr dataPtr :: Ptr Int64) rowIdx-                                     DuckDBTypeHugeInt ->-                                         toInteger . duckDBHugeIntToInteger <$>-                                            peekElemOff (castPtr dataPtr :: Ptr DuckDBHugeInt) rowIdx-                                     _ -> error "duckdb-simple: unsupported decimal internal storage type"-                                 pure (FieldDecimal (DecimalValue width scale raw))-                DuckDBTypeHugeInt -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBHugeInt) rowIdx-                    pure (FieldHugeInt (duckDBHugeIntToInteger raw))-                DuckDBTypeUHugeInt -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBUHugeInt) rowIdx-                    pure (FieldUHugeInt (duckDBUHugeIntToInteger raw))-                DuckDBTypeBit -> do-                    -- Same deal as with bignum, we need to manually decode the string_t-                    let base = castPtr dataPtr :: Ptr Word8-                        -- luckily, the underlying data has only one field, which is a string_t-                        offset = fromIntegral rowIdx * duckdbStringTSize-                        stringPtr = castPtr (base `plusPtr` offset) :: Ptr DuckDBStringT-                    len <- c_duckdb_string_t_length stringPtr-                    ptr <- c_duckdb_string_t_data stringPtr-                    bs <- BS.unpack <$> BS.packCStringLen (ptr, fromIntegral len)-                    case bs of-                       [] -> return $ FieldBit (BitString 0 BS.empty)-                       [padding] -> return $ FieldBit (BitString padding BS.empty)-                       (padding:b:bits) -> do-                           let tc = [(8-fromIntegral padding)..7]-                               cleared = foldl clearBit b tc-                           return $ FieldBit $ BitString padding (BS.pack (cleared:bits))-                DuckDBTypeBigNum -> do-                    -- Here we have to get messy, because DuckDB returns a pointer-                    -- to a bignum_t and not a duckdb_bignum.-                    let base = castPtr dataPtr :: Ptr Word8-                        -- luckily, the underlying data has only one field, which is a string_t-                        offset = fromIntegral rowIdx * duckdbStringTSize-                        stringPtr = castPtr (base `plusPtr` offset) :: Ptr DuckDBStringT-                    len <- c_duckdb_string_t_length stringPtr-                    if len < 3-                    then return $ FieldBigNum (BigNum 0)-                    else do ptr <- c_duckdb_string_t_data stringPtr-                            bs <- BS.unpack <$> BS.packCStringLen (ptr, fromIntegral len)-                            return $ FieldBigNum $ BigNum (fromBigNumBytes bs)-                DuckDBTypeList -> FieldList <$> decodeListElements vector dataPtr rowIdx-                DuckDBTypeMap -> FieldMap <$> decodeMapPairs vector dataPtr rowIdx-                DuckDBTypeStruct -> error "duckdb-simple: STRUCT columns are not supported"-                DuckDBTypeUnion -> error "duckdb-simple: UNION columns are not supported"-                DuckDBTypeEnum -> do-                    bracket (c_duckdb_vector_get_column_type vector)-                            (\lty -> alloca $ \ptr -> poke ptr lty >> c_duckdb_destroy_logical_type ptr) $-                            \logical -> do-                              enumInternal <- c_duckdb_enum_internal_type logical-                              FieldEnum <$>-                                case enumInternal of-                                    DuckDBTypeUTinyInt -> do-                                        fromIntegral <$> peekElemOff (castPtr dataPtr :: Ptr Word8) rowIdx-                                    DuckDBTypeUSmallInt -> do-                                        fromIntegral <$> peekElemOff (castPtr dataPtr :: Ptr Word16) rowIdx-                                    DuckDBTypeUInteger -> do-                                        fromIntegral <$> peekElemOff (castPtr dataPtr :: Ptr Word32) rowIdx-                                    _ -> error "duckdb-simple: unsupported enum internal storage type"-                DuckDBTypeSQLNull ->-                    pure FieldNull-                DuckDBTypeStringLiteral -> FieldText <$> chunkDecodeText dataPtr duckIdx-                DuckDBTypeIntegerLiteral -> do-                    raw <- peekElemOff (castPtr dataPtr :: Ptr Int64) rowIdx-                    pure (FieldInt64 raw)-                other ->-                    error ("duckdb-simple: unsupported DuckDB type in eager result: " <> show other)--decodeDuckDBDate :: DuckDBDate -> IO Day-decodeDuckDBDate raw =-    alloca \ptr -> do-        c_duckdb_from_date raw ptr-        dateStruct <- peek ptr-        pure (dateStructToDay dateStruct)--decodeDuckDBTime :: DuckDBTime -> IO TimeOfDay-decodeDuckDBTime raw =-    alloca \ptr -> do-        c_duckdb_from_time raw ptr-        timeStruct <- peek ptr-        pure (timeStructToTimeOfDay timeStruct)--decodeDuckDBTimestamp :: DuckDBTimestamp -> IO LocalTime-decodeDuckDBTimestamp raw =-    alloca \ptr -> do-        c_duckdb_from_timestamp raw ptr-        DuckDBTimestampStruct{duckDBTimestampStructDate = dateStruct, duckDBTimestampStructTime = timeStruct} <- peek ptr-        pure-            LocalTime-                { localDay = dateStructToDay dateStruct-                , localTimeOfDay = timeStructToTimeOfDay timeStruct-                }--dateStructToDay :: DuckDBDateStruct -> Day-dateStructToDay DuckDBDateStruct{duckDBDateStructYear, duckDBDateStructMonth, duckDBDateStructDay} =-    fromGregorian (fromIntegral duckDBDateStructYear) (fromIntegral duckDBDateStructMonth) (fromIntegral duckDBDateStructDay)--timeStructToTimeOfDay :: DuckDBTimeStruct -> TimeOfDay-timeStructToTimeOfDay DuckDBTimeStruct{duckDBTimeStructHour, duckDBTimeStructMinute, duckDBTimeStructSecond, duckDBTimeStructMicros} =-    let secondsInt = fromIntegral duckDBTimeStructSecond :: Integer-        micros = fromIntegral duckDBTimeStructMicros :: Integer-        fractional = fromRational (micros % 1000000)-        totalSeconds = fromInteger secondsInt + fractional-     in TimeOfDay-            (fromIntegral duckDBTimeStructHour)-            (fromIntegral duckDBTimeStructMinute)-            totalSeconds--decodeDuckDBTimeNs :: DuckDBTimeNs -> TimeOfDay-decodeDuckDBTimeNs (DuckDBTimeNs nanos) =-    let (hours, remainderHours) = nanos `divMod` (60 * 60 * 1000000000)-        (minutes, remainderMinutes) = remainderHours `divMod` (60 * 1000000000)-        (seconds, fractionalNanos) = remainderMinutes `divMod` 1000000000-        fractional = fromRational (toInteger fractionalNanos % 1000000000)-        totalSeconds = fromIntegral seconds + fractional-     in TimeOfDay-            (fromIntegral hours)-            (fromIntegral minutes)-            totalSeconds--decodeDuckDBTimeTz :: DuckDBTimeTz -> IO TimeWithZone-decodeDuckDBTimeTz raw =-    alloca \ptr -> do-        c_duckdb_from_time_tz raw ptr-        DuckDBTimeTzStruct{duckDBTimeTzStructTime = timeStruct, duckDBTimeTzStructOffset = offset} <- peek ptr-        let timeOfDay = timeStructToTimeOfDay timeStruct-            minutes = fromIntegral offset `div` 60-            zone = minutesToTimeZone minutes-        pure TimeWithZone{timeWithZoneTime = timeOfDay, timeWithZoneZone = zone}--decodeDuckDBTimestampSeconds :: DuckDBTimestampS -> IO LocalTime-decodeDuckDBTimestampSeconds (DuckDBTimestampS seconds) =-    decodeDuckDBTimestamp (DuckDBTimestamp (seconds * 1000000))--decodeDuckDBTimestampMilliseconds :: DuckDBTimestampMs -> IO LocalTime-decodeDuckDBTimestampMilliseconds (DuckDBTimestampMs millis) =-    decodeDuckDBTimestamp (DuckDBTimestamp (millis * 1000))--decodeDuckDBTimestampNanoseconds :: DuckDBTimestampNs -> IO LocalTime-decodeDuckDBTimestampNanoseconds (DuckDBTimestampNs nanos) = do-    let utcTime = posixSecondsToUTCTime (fromRational (toInteger nanos % 1000000000))-    pure (utcToLocalTime utc utcTime)--decodeDuckDBTimestampUTCTime :: DuckDBTimestamp -> IO UTCTime-decodeDuckDBTimestampUTCTime (DuckDBTimestamp micros) =-    pure (posixSecondsToUTCTime (fromRational (toInteger micros % 1000000)))--intervalValueFromDuckDB :: DuckDBInterval -> IntervalValue-intervalValueFromDuckDB DuckDBInterval{duckDBIntervalMonths, duckDBIntervalDays, duckDBIntervalMicros} =-    IntervalValue-        { intervalMonths = duckDBIntervalMonths-        , intervalDays = duckDBIntervalDays-        , intervalMicros = duckDBIntervalMicros-        }---duckDBHugeIntToInteger :: DuckDBHugeInt -> Integer-duckDBHugeIntToInteger DuckDBHugeInt{duckDBHugeIntLower, duckDBHugeIntUpper} =-    (fromIntegral duckDBHugeIntUpper `shiftL` 64) .|. fromIntegral duckDBHugeIntLower--duckDBUHugeIntToInteger :: DuckDBUHugeInt -> Integer-duckDBUHugeIntToInteger DuckDBUHugeInt{duckDBUHugeIntLower, duckDBUHugeIntUpper} =-    (fromIntegral duckDBUHugeIntUpper `shiftL` 64) .|. fromIntegral duckDBUHugeIntLower  peekError :: Ptr CString -> IO Text peekError ptr = do

@@ -1,4 +1,3 @@-{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}@@ -16,6 +15,11 @@ module Database.DuckDB.Simple.FromField (     Field (..),     FieldValue (..),+    StructField (..),+    StructValue (..),+    UnionMemberType (..),+    UnionValue (..),+    LogicalTypeRep (..),     BitString(..),     bsFromBool,     BigNum (..),@@ -33,6 +37,7 @@ import Control.Exception (Exception, SomeException (..)) import Data.Bits (Bits (..), finiteBitSize) import qualified Data.ByteString as BS+import Data.Array (Array, (!), bounds, listArray, range, assocs) import Data.Data (Typeable, typeRep) import Data.Int (Int16, Int32, Int64, Int8) import Data.Map.Strict (Map)@@ -57,6 +62,13 @@ import GHC.Num.Integer (integerFromWordList) import Numeric.Natural (Natural) import qualified Data.UUID as UUID+import Database.DuckDB.Simple.LogicalRep (+    LogicalTypeRep (..),+    StructField (..),+    StructValue (..),+    UnionMemberType (..),+    UnionValue (..)+ )  -- | Internal representation of a column value. data FieldValue@@ -87,8 +99,11 @@     | FieldBit BitString     | FieldBigNum BigNum     | FieldEnum Word32+    | FieldArray (Array Int FieldValue)     | FieldList [FieldValue]     | FieldMap [(FieldValue, FieldValue)]+    | FieldStruct (StructValue FieldValue)+    | FieldUnion (UnionValue FieldValue)     deriving (Eq, Show)  data DecimalValue = DecimalValue@@ -279,6 +294,20 @@ instance FromField FieldValue where     fromField Field{fieldValue} = Ok fieldValue +instance FromField (StructValue FieldValue) where+    fromField f@Field{fieldValue} =+        case fieldValue of+            FieldStruct structVal -> Ok structVal+            FieldNull -> returnError UnexpectedNull f ""+            _ -> returnError Incompatible f "expected STRUCT"++instance FromField (UnionValue FieldValue) where+    fromField f@Field{fieldValue} =+        case fieldValue of+            FieldUnion unionVal -> Ok unionVal+            FieldNull -> returnError UnexpectedNull f ""+            _ -> returnError Incompatible f "expected UNION"+ instance FromField Null where     fromField f@Field{fieldValue} =         case fieldValue of@@ -528,6 +557,8 @@         case fieldValue of             FieldList entries ->                 traverse (uncurry parseElement) (zip [0 :: Int ..] entries)+            FieldArray arr ->+                traverse (uncurry parseElement) (assocs arr)             FieldNull -> returnError UnexpectedNull f ""             _ -> returnError Incompatible f ""       where@@ -543,6 +574,26 @@                 idxText = Text.pack (show idx)              in base <> Text.pack "[" <> idxText <> Text.pack "]" +instance (Typeable a, FromField a) => FromField (Array Int a) where+    fromField f@Field{fieldValue} =+        case fieldValue of+            FieldArray arr -> do+                converted <- traverse (traverseElement arr) (range (bounds arr))+                pure (listArray (bounds arr) converted)+            FieldNull -> returnError UnexpectedNull f ""+            _ -> returnError Incompatible f ""+      where+        traverseElement arr idx =+            fromField+                Field+                    { fieldName = fieldNameWithIndex idx+                    , fieldIndex = fieldIndex f+                    , fieldValue = arr ! idx+                    }+        fieldNameWithIndex idx =+            let idxText = Text.pack (show idx)+             in fieldName f <> Text.pack "[" <> idxText <> Text.pack "]"+ instance (Ord k, Typeable k, Typeable v, FromField k, FromField v) => FromField (Map k v) where     fromField f@Field{fieldValue} =         case fieldValue of@@ -692,6 +743,9 @@     FieldBit{} -> "BIT"     FieldBigNum{} -> "BIGNUM"     FieldEnum{} -> "ENUM"+    FieldArray{} -> "ARRAY"     FieldList{} -> "LIST"     FieldMap{} -> "MAP"     FieldUUID{} -> "UUID"+    FieldStruct{} -> "STRUCT"+    FieldUnion{} -> "UNION"

@@ -1,7 +1,6 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-}@@ -31,52 +30,31 @@     try,  ) import Control.Monad (forM, forM_, when)-import Data.Bits (shiftL, (.|.), clearBit)-import qualified Data.ByteString as BS-import Data.Int (Int16, Int32, Int64, Int8)+import Data.Int (Int16, Int32, Int64) import Data.Proxy (Proxy (..))-import Data.Ratio ((%)) import Data.Text (Text) import qualified Data.Text as Text-import qualified Data.Text.Encoding as TE import qualified Data.Text.Foreign as TextForeign-import Data.Time.Calendar (Day, fromGregorian)-import Data.Time.Clock (UTCTime (..))-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-import Data.Time.LocalTime (-    LocalTime (..),-    TimeOfDay (..),-    minutesToTimeZone,-    utc,-    utcToLocalTime,- ) import Data.Word (Word16, Word32, Word64, Word8) import Database.DuckDB.FFI import Database.DuckDB.Simple.FromField (-    BigNum (..),-    BitString (..),-    DecimalValue (..),     Field (..),-    FieldValue (..),     FromField (..),-    IntervalValue (..),-    TimeWithZone (..),-    fromBigNumBytes,  ) import Database.DuckDB.Simple.Internal (     Connection,     Query (..),     SQLError (..),     withConnectionHandle,-    withQueryCString,- )+    withQueryCString+    )+import Database.DuckDB.Simple.Materialize (materializeValue) import Database.DuckDB.Simple.Ok (Ok (..)) import Foreign.C.String (peekCString)-import Foreign.C.Types (CBool (..)) import Foreign.Marshal.Alloc (alloca)-import Foreign.Ptr (Ptr, castPtr, freeHaskellFunPtr, nullPtr, plusPtr)+import Foreign.Ptr (Ptr, castPtr, freeHaskellFunPtr, nullPtr) import Foreign.StablePtr (StablePtr, castPtrToStablePtr, castStablePtrToPtr, deRefStablePtr, freeStablePtr, newStablePtr)-import Foreign.Storable (peek, peekElemOff, poke, pokeElemOff)+import Foreign.Storable (poke, pokeElemOff)  -- | Tag DuckDB logical types we support for scalar return values. data ScalarType@@ -381,316 +359,18 @@     vector <- c_duckdb_data_chunk_get_vector chunk (fromIntegral columnIndex)     logical <- c_duckdb_vector_get_column_type vector     dtype <- c_duckdb_get_type_id logical-    decimalInfo <--        if dtype == DuckDBTypeDecimal-            then do-                width <- c_duckdb_decimal_width logical-                scale <- c_duckdb_decimal_scale logical-                pure (Just (width, scale))-            else pure Nothing-    enumInternal <--        if dtype == DuckDBTypeEnum-            then Just <$> c_duckdb_enum_internal_type logical-            else pure Nothing     destroyLogicalType logical     dataPtr <- c_duckdb_vector_get_data vector     validity <- c_duckdb_vector_get_validity vector     let name = Text.pack ("arg" <> show columnIndex)     pure \rowIdx -> do-        valid <- isRowValid validity rowIdx-        value <--            if valid-                then fetchValue dtype decimalInfo enumInternal dataPtr rowIdx-                else pure FieldNull+        value <- materializeValue dtype vector dataPtr validity (fromIntegral rowIdx)         pure             Field                 { fieldName = name                 , fieldIndex = columnIndex                 , fieldValue = value                 }--isRowValid :: Ptr Word64 -> DuckDBIdx -> IO Bool-isRowValid validity rowIdx-    | validity == nullPtr = pure True-    | otherwise = do-        CBool flag <- c_duckdb_validity_row_is_valid validity rowIdx-        pure (flag /= 0)--fetchValue :: DuckDBType -> Maybe (Word8, Word8) -> Maybe DuckDBType -> Ptr () -> DuckDBIdx -> IO FieldValue-fetchValue dtype decimalInfo enumInternal dataPtr rowIdx =-    let idx = fromIntegral rowIdx-     in case dtype of-            DuckDBTypeBoolean -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr Word8) idx-                pure (FieldBool (value /= 0))-            DuckDBTypeTinyInt -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr Int8) idx-                pure (FieldInt8 value)-            DuckDBTypeSmallInt -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr Int16) idx-                pure (FieldInt16 value)-            DuckDBTypeInteger -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr Int32) idx-                pure (FieldInt32 value)-            DuckDBTypeBigInt -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr Int64) idx-                pure (FieldInt64 value)-            DuckDBTypeHugeInt -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBHugeInt) idx-                pure (FieldHugeInt (duckDBHugeIntToInteger value))-            DuckDBTypeUTinyInt -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr Word8) idx-                pure (FieldWord8 value)-            DuckDBTypeUSmallInt -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr Word16) idx-                pure (FieldWord16 value)-            DuckDBTypeUInteger -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr Word32) idx-                pure (FieldWord32 value)-            DuckDBTypeUBigInt -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr Word64) idx-                pure (FieldWord64 value)-            DuckDBTypeUHugeInt -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBUHugeInt) idx-                pure (FieldUHugeInt (duckDBUHugeIntToInteger value))-            DuckDBTypeFloat -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr Float) idx-                pure (FieldFloat value)-            DuckDBTypeDouble -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr Double) idx-                pure (FieldDouble value)-            DuckDBTypeVarchar -> FieldText <$> decodeDuckText dataPtr rowIdx-            DuckDBTypeUUID -> FieldText <$> decodeDuckText dataPtr rowIdx-            DuckDBTypeBlob -> FieldBlob <$> decodeDuckBlob dataPtr rowIdx-            DuckDBTypeDate -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBDate) idx-                FieldDate <$> decodeDuckDBDate value-            DuckDBTypeTime -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTime) idx-                FieldTime <$> decodeDuckDBTime value-            DuckDBTypeTimeNs -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimeNs) idx-                pure (FieldTime (decodeDuckDBTimeNs value))-            DuckDBTypeTimeTz -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimeTz) idx-                FieldTimeTZ <$> decodeDuckDBTimeTz value-            DuckDBTypeTimestamp -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestamp) idx-                FieldTimestamp <$> decodeDuckDBTimestamp value-            DuckDBTypeTimestampS -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestampS) idx-                FieldTimestamp <$> decodeDuckDBTimestampSeconds value-            DuckDBTypeTimestampMs -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestampMs) idx-                FieldTimestamp <$> decodeDuckDBTimestampMilliseconds value-            DuckDBTypeTimestampNs -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestampNs) idx-                FieldTimestamp <$> decodeDuckDBTimestampNanoseconds value-            DuckDBTypeTimestampTz -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestamp) idx-                FieldTimestampTZ <$> decodeDuckDBTimestampUTCTime value-            DuckDBTypeInterval -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBInterval) idx-                pure (FieldInterval (intervalValueFromDuckDB value))-            DuckDBTypeDecimal -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr DuckDBDecimal) idx-                case decimalInfo of-                    Just (width, scale) -> do-                        decimal <- decimalValueFromDuckDB width scale value-                        pure (FieldDecimal decimal)-                    Nothing ->-                        throwIO $-                            functionInvocationError $-                                Text.pack "duckdb-simple: missing decimal metadata for scalar function argument"-            DuckDBTypeBit -> do-                -- Same deal as with bignum, we need to manually decode the string_t-                let base = castPtr dataPtr :: Ptr Word8-                    -- luckily, the underlying data has only one field, which is a string_t-                    offset = fromIntegral rowIdx * duckdbStringTSize-                    stringPtr = castPtr (base `plusPtr` offset) :: Ptr DuckDBStringT-                len <- c_duckdb_string_t_length stringPtr-                ptr <- c_duckdb_string_t_data stringPtr-                bs <- BS.unpack <$> BS.packCStringLen (ptr, fromIntegral len)-                case bs of-                    [] -> return $ FieldBit (BitString 0 BS.empty)-                    [padding] -> return $ FieldBit (BitString padding BS.empty)-                    (padding:b:bits) ->-                        let cleared = foldl clearBit b [0..fromIntegral padding -1]-                        in return $ FieldBit $ BitString padding (BS.pack (cleared:bits))-            DuckDBTypeBigNum -> do-                let base = castPtr dataPtr :: Ptr Word8-                    -- luckily, the underlying data has only one field, which is a string_t-                    offset = fromIntegral rowIdx * duckdbStringTSize-                    stringPtr = castPtr (base `plusPtr` offset) :: Ptr DuckDBStringT-                len <- c_duckdb_string_t_length stringPtr-                if len < 3-                    then return $ FieldBigNum (BigNum 0)-                    else do-                        ptr <- c_duckdb_string_t_data stringPtr-                        bs <- BS.unpack <$> BS.packCStringLen (ptr, fromIntegral len)-                        return $ FieldBigNum $ BigNum (fromBigNumBytes bs)-            DuckDBTypeEnum -> do-                case enumInternal of-                    Just DuckDBTypeUTinyInt -> do-                        value <- peekElemOff (castPtr dataPtr :: Ptr Word8) idx-                        pure (FieldEnum (fromIntegral value))-                    Just DuckDBTypeUSmallInt -> do-                        value <- peekElemOff (castPtr dataPtr :: Ptr Word16) idx-                        pure (FieldEnum (fromIntegral value))-                    Just DuckDBTypeUInteger -> do-                        value <- peekElemOff (castPtr dataPtr :: Ptr Word32) idx-                        pure (FieldEnum value)-                    _ ->-                        throwIO $-                            functionInvocationError $-                                Text.pack "duckdb-simple: unsupported enum internal storage type for scalar function argument"-            DuckDBTypeSQLNull ->-                pure FieldNull-            DuckDBTypeStringLiteral -> FieldText <$> decodeDuckText dataPtr rowIdx-            DuckDBTypeIntegerLiteral -> do-                value <- peekElemOff (castPtr dataPtr :: Ptr Int64) idx-                pure (FieldInt64 value)-            other ->-                throwIO $-                    functionInvocationError $-                        Text.concat-                            [ Text.pack "duckdb-simple: unsupported argument type "-                            , Text.pack (show other)-                            ]--decodeDuckText :: Ptr () -> DuckDBIdx -> IO Text-decodeDuckText dataPtr rowIdx = do-    let bytePtr = castPtr dataPtr :: Ptr Word8-        offset = fromIntegral rowIdx * duckdbStringTSize-        stringPtr = castPtr (bytePtr `plusPtr` offset) :: Ptr DuckDBStringT-    len <- c_duckdb_string_t_length stringPtr-    if len == 0-        then pure Text.empty-        else do-            cstr <- c_duckdb_string_t_data stringPtr-            bytes <- BS.packCStringLen (cstr, fromIntegral len)-            pure (TE.decodeUtf8 bytes)--decodeDuckBlob :: Ptr () -> DuckDBIdx -> IO BS.ByteString-decodeDuckBlob dataPtr rowIdx = do-    let bytePtr = castPtr dataPtr :: Ptr Word8-        offset = fromIntegral rowIdx * duckdbStringTSize-        stringPtr = castPtr (bytePtr `plusPtr` offset) :: Ptr DuckDBStringT-    len <- c_duckdb_string_t_length stringPtr-    if len == 0-        then pure BS.empty-        else do-            ptr <- c_duckdb_string_t_data stringPtr-            BS.packCStringLen (ptr, fromIntegral len)--duckdbStringTSize :: Int-duckdbStringTSize = 16--decodeDuckDBDate :: DuckDBDate -> IO Day-decodeDuckDBDate raw =-    alloca \ptr -> do-        c_duckdb_from_date raw ptr-        dateStruct <- peek ptr-        pure (dateStructToDay dateStruct)--decodeDuckDBTime :: DuckDBTime -> IO TimeOfDay-decodeDuckDBTime raw =-    alloca \ptr -> do-        c_duckdb_from_time raw ptr-        timeStruct <- peek ptr-        pure (timeStructToTimeOfDay timeStruct)--decodeDuckDBTimestamp :: DuckDBTimestamp -> IO LocalTime-decodeDuckDBTimestamp raw =-    alloca \ptr -> do-        c_duckdb_from_timestamp raw ptr-        DuckDBTimestampStruct{duckDBTimestampStructDate = dateStruct, duckDBTimestampStructTime = timeStruct} <- peek ptr-        pure-            LocalTime-                { localDay = dateStructToDay dateStruct-                , localTimeOfDay = timeStructToTimeOfDay timeStruct-                }--dateStructToDay :: DuckDBDateStruct -> Day-dateStructToDay DuckDBDateStruct{duckDBDateStructYear, duckDBDateStructMonth, duckDBDateStructDay} =-    fromGregorian (fromIntegral duckDBDateStructYear) (fromIntegral duckDBDateStructMonth) (fromIntegral duckDBDateStructDay)--timeStructToTimeOfDay :: DuckDBTimeStruct -> TimeOfDay-timeStructToTimeOfDay DuckDBTimeStruct{duckDBTimeStructHour, duckDBTimeStructMinute, duckDBTimeStructSecond, duckDBTimeStructMicros} =-    let secondsInt = fromIntegral duckDBTimeStructSecond :: Integer-        micros = fromIntegral duckDBTimeStructMicros :: Integer-        fractional = fromRational (micros % 1000000)-        totalSeconds = fromInteger secondsInt + fractional-     in TimeOfDay-            (fromIntegral duckDBTimeStructHour)-            (fromIntegral duckDBTimeStructMinute)-            totalSeconds--decodeDuckDBTimeNs :: DuckDBTimeNs -> TimeOfDay-decodeDuckDBTimeNs (DuckDBTimeNs nanos) =-    let (hours, remainderHours) = nanos `divMod` (60 * 60 * 1000000000)-        (minutes, remainderMinutes) = remainderHours `divMod` (60 * 1000000000)-        (seconds, fractionalNanos) = remainderMinutes `divMod` 1000000000-        fractional = fromRational (toInteger fractionalNanos % 1000000000)-        totalSeconds = fromIntegral seconds + fractional-     in TimeOfDay-            (fromIntegral hours)-            (fromIntegral minutes)-            totalSeconds--decodeDuckDBTimeTz :: DuckDBTimeTz -> IO TimeWithZone-decodeDuckDBTimeTz raw =-    alloca \ptr -> do-        c_duckdb_from_time_tz raw ptr-        DuckDBTimeTzStruct{duckDBTimeTzStructTime = timeStruct, duckDBTimeTzStructOffset = offset} <- peek ptr-        let timeOfDay = timeStructToTimeOfDay timeStruct-            minutes = fromIntegral offset `div` 60-            zone = minutesToTimeZone minutes-        pure TimeWithZone{timeWithZoneTime = timeOfDay, timeWithZoneZone = zone}--decodeDuckDBTimestampSeconds :: DuckDBTimestampS -> IO LocalTime-decodeDuckDBTimestampSeconds (DuckDBTimestampS seconds) =-    decodeDuckDBTimestamp (DuckDBTimestamp (seconds * 1000000))--decodeDuckDBTimestampMilliseconds :: DuckDBTimestampMs -> IO LocalTime-decodeDuckDBTimestampMilliseconds (DuckDBTimestampMs millis) =-    decodeDuckDBTimestamp (DuckDBTimestamp (millis * 1000))--decodeDuckDBTimestampNanoseconds :: DuckDBTimestampNs -> IO LocalTime-decodeDuckDBTimestampNanoseconds (DuckDBTimestampNs nanos) = do-    let utcTime = posixSecondsToUTCTime (fromRational (toInteger nanos % 1000000000))-    pure (utcToLocalTime utc utcTime)--decodeDuckDBTimestampUTCTime :: DuckDBTimestamp -> IO UTCTime-decodeDuckDBTimestampUTCTime (DuckDBTimestamp micros) =-    pure (posixSecondsToUTCTime (fromRational (toInteger micros % 1000000)))--intervalValueFromDuckDB :: DuckDBInterval -> IntervalValue-intervalValueFromDuckDB DuckDBInterval{duckDBIntervalMonths, duckDBIntervalDays, duckDBIntervalMicros} =-    IntervalValue-        { intervalMonths = duckDBIntervalMonths-        , intervalDays = duckDBIntervalDays-        , intervalMicros = duckDBIntervalMicros-        }--decimalValueFromDuckDB :: Word8 -> Word8 -> DuckDBDecimal -> IO DecimalValue-decimalValueFromDuckDB width scale rawDecimal = do-    let decimal = rawDecimal{duckDBDecimalWidth = width, duckDBDecimalScale = scale}-    pure-        DecimalValue-            { decimalWidth = width-            , decimalScale = scale-            , decimalInteger = duckDBHugeIntToInteger (duckDBDecimalValue decimal)-            }--duckDBHugeIntToInteger :: DuckDBHugeInt -> Integer-duckDBHugeIntToInteger DuckDBHugeInt{duckDBHugeIntLower, duckDBHugeIntUpper} =-    (fromIntegral duckDBHugeIntUpper `shiftL` 64) .|. fromIntegral duckDBHugeIntLower--duckDBUHugeIntToInteger :: DuckDBUHugeInt -> Integer-duckDBUHugeIntToInteger DuckDBUHugeInt{duckDBUHugeIntLower, duckDBUHugeIntUpper} =-    (fromIntegral duckDBUHugeIntUpper `shiftL` 64) .|. fromIntegral duckDBUHugeIntLower- writeResults :: ScalarType -> [ScalarValue] -> DuckDBVector -> IO () writeResults resultType values outVec = do     let hasNulls = any isNullValue values

@@ -0,0 +1,724 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+Module      : Database.DuckDB.Simple.Generic+Description : Generic helpers for encoding Haskell ADTs as DuckDB structs/unions.++This module provides the glue needed to reuse the existing 'ToField'/'FromField'+machinery with algebraic data types via GHC generics.  The supported mapping is+currently intentionally conservative:++* /Product types/ (records or tuples) whose fields already satisfy 'DuckValue'+  are encoded as STRUCT values.  Record fields retain their selector name;+  positional products fall back to @field1@, @field2@, …+* /Sum types/ (:+:) become UNION values.  Each constructor becomes a union+  member; payloads are encoded as structs (or @NULL@ for nullary constructors).++Recursive types are supported as long as every payload is itself encodable+through 'DuckValue'.  Note that sum types must have constructor fields that are+structural products (i.e. we do not yet expose mixed union/record nesting for+non-record constructors).++Typical usage looks like:++> data User = User { userId :: Int64, userName :: Text }+>   deriving stock (Generic)+>+> instance DuckValue User+>+> toField (genericToFieldValue user) -- Struct {"userId" := ..., ...}++For sum types:++> data Shape+>   = Circle Double+>   | Rectangle Double Double+>   | Origin+>   deriving stock (Generic)+>+> instance DuckValue Shape++Constructors are turned into a union with members @Circle{radius}@,+@Rectangle{width,height}@, and @Origin@ (null payload).++You can also lean on @DerivingVia@ using the exported 'ViaDuckDB' newtype:++> data User = User { userId :: Int64, userName :: Text }+>   deriving stock (Generic)+>   deriving (DuckDBColumnType, ToField, FromField) via (ViaDuckDB User)++The derived instances automatically encode/decode via STRUCT/UNION representations.++=== Extending this module++The rest of this file is organised so that each building block is reusable:++* 'DuckValue' covers leaf-level conversions between Haskell values, DuckDB+  'FieldValue's, and logical type metadata.+* 'GToField' and friends walk the generic representation to assemble structs or+  unions and carry around the logical type information we later need when+  binding parameters.+* 'ViaDuckDB' wires everything together for deriving via.++When adding new features, mimic the structure used here (and document new+classes the way the existing ones are documented) so other backends can take+inspiration from this implementation.+-}+module Database.DuckDB.Simple.Generic (+    -- * Field-level primitives+    DuckValue (..),++    -- * Generic encoding/decoding for ADTs+    genericToFieldValue,+    genericFromFieldValue,+    genericLogicalType,+    genericToStructValue,+    genericToUnionValue,++    -- * DerivingVia helper+    ViaDuckDB (..),+) where++import Control.Exception (displayException)+import Control.Monad (unless)+import Data.Array (Array, elems, listArray)+import Data.Int (Int16, Int32, Int64, Int8)+import qualified Data.Map.Strict as Map+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time.Calendar (Day)+import Data.Time.LocalTime (LocalTime, TimeOfDay)+import Data.Time (UTCTime)+import Data.Word (Word16, Word32, Word64, Word8)+import qualified Data.ByteString as BS+import qualified Data.UUID as UUID+import GHC.Generics+import Numeric.Natural (Natural)+import Data.Typeable (Typeable)++import Database.DuckDB.FFI+import Database.DuckDB.Simple.FromField (+    Field (..),+    FieldValue (..),+    FromField (..),+    IntervalValue (..),+    ResultError (..),+    TimeWithZone (..),+    returnError,+ )+import Database.DuckDB.Simple.LogicalRep (+    LogicalTypeRep (..),+    StructField (..),+    StructValue (..),+    UnionMemberType (..),+    UnionValue (..),+ )+import Database.DuckDB.Simple.Ok (Ok (..))+import Database.DuckDB.Simple.ToField (DuckDBColumnType (..), ToField (..))++--------------------------------------------------------------------------------+-- DuckValue: bridge between Haskell scalars and FieldValue/LogicalTypeRep++-- | Types that can appear inside generated structs/unions.+--+-- A 'DuckValue' instance must provide:+--+-- * encoding to 'FieldValue'+-- * logical type metadata ('duckLogicalType')+-- * decoding from 'FieldValue'+--+-- The primitive instances below are the canonical source for how scalar types+-- should be represented; both the generic implementation and the manual+-- 'ToField'/'FromField' instances rely on them.+class DuckValue a where+    duckToField :: a -> FieldValue+    duckFromField :: FieldValue -> Either String a+    duckLogicalType :: Proxy a -> LogicalTypeRep++    default duckFromField :: (FromField a, Show a) => FieldValue -> Either String a+    duckFromField fv =+        case fromField Field{fieldName = Text.empty, fieldIndex = 0, fieldValue = fv} of+            Ok x -> Right x+            Errors errs -> Left (unlines (map displayException errs))++instance DuckValue Bool where+    duckToField = FieldBool+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeBoolean++instance DuckValue Int where+    duckToField = FieldInt64 . fromIntegral+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeBigInt++instance DuckValue Int8 where+    duckToField = FieldInt8+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeTinyInt++instance DuckValue Int16 where+    duckToField = FieldInt16+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeSmallInt++instance DuckValue Int32 where+    duckToField = FieldInt32+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeInteger++instance DuckValue Int64 where+    duckToField = FieldInt64+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeBigInt++instance DuckValue Integer where+    duckToField = FieldHugeInt+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeHugeInt++instance DuckValue Natural where+    duckToField = FieldUHugeInt . toInteger+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeUHugeInt++instance DuckValue Word where+    duckToField = FieldWord64 . fromIntegral+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeUBigInt++instance DuckValue Word8 where+    duckToField = FieldWord8+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeUTinyInt++instance DuckValue Word16 where+    duckToField = FieldWord16+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeUSmallInt++instance DuckValue Word32 where+    duckToField = FieldWord32+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeUInteger++instance DuckValue Word64 where+    duckToField = FieldWord64+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeUBigInt++instance DuckValue Float where+    duckToField = FieldFloat+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeFloat++instance DuckValue Double where+    duckToField = FieldDouble+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeDouble++instance DuckValue Text where+    duckToField = FieldText+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeVarchar++instance DuckValue String where+    duckToField = FieldText . Text.pack+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeVarchar+    duckFromField fv = Text.unpack <$> duckFromField fv++instance DuckValue BS.ByteString where+    duckToField = FieldBlob+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeBlob++instance DuckValue Day where+    duckToField = FieldDate+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeDate++instance DuckValue TimeOfDay where+    duckToField = FieldTime+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeTime++instance DuckValue LocalTime where+    duckToField = FieldTimestamp+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeTimestamp++instance DuckValue UTCTime where+    duckToField = FieldTimestampTZ+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeTimestampTz++instance DuckValue UUID.UUID where+    duckToField = FieldUUID+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeUUID++instance DuckValue IntervalValue where+    duckToField = FieldInterval+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeInterval++instance DuckValue TimeWithZone where+    duckToField = FieldTimeTZ+    duckLogicalType _ = LogicalTypeScalar DuckDBTypeTimeTz++instance (DuckValue a) => DuckValue (Maybe a) where+    duckToField (Just x) = duckToField x+    duckToField Nothing = FieldNull+    duckLogicalType _ = duckLogicalType (Proxy :: Proxy a)+    duckFromField FieldNull = Right Nothing+    duckFromField other = Just <$> duckFromField other++-- | List values encode as DuckDB LIST (variable-length).+instance (DuckValue a) => DuckValue [a] where+    duckToField xs = FieldList (map duckToField xs)+    duckLogicalType _ = LogicalTypeList (duckLogicalType (Proxy :: Proxy a))+    duckFromField (FieldList fvs) = traverse duckFromField fvs+    duckFromField other = Left ("duckdb-simple: expected LIST, got " <> show other)++-- | Array values encode as DuckDB ARRAY (fixed-length).+-- Note: Arrays must have consistent bounds to work correctly with DuckDB.+instance (DuckValue a) => DuckValue (Array Int a) where+    duckToField arr =+        let values = elems arr+            (low, high) = (0, length values - 1)+         in FieldArray (listArray (low, high) (map duckToField values))+    duckLogicalType _ =+        -- We can't determine array size at the type level, so this is approximate.+        -- The actual size will be determined at runtime from the array bounds.+        LogicalTypeArray (duckLogicalType (Proxy :: Proxy a)) 0+    duckFromField (FieldArray arr) = do+        let values = elems arr+        decoded <- traverse duckFromField values+        let (low, high) = (0, length decoded - 1)+        pure (listArray (low, high) decoded)+    duckFromField other = Left ("duckdb-simple: expected ARRAY, got " <> show other)++-- | Map values encode as DuckDB MAP.+instance (Ord k, DuckValue k, DuckValue v) => DuckValue (Map.Map k v) where+    duckToField m =+        let pairs = Map.toList m+         in FieldMap [(duckToField k, duckToField v) | (k, v) <- pairs]+    duckLogicalType _ =+        LogicalTypeMap+            (duckLogicalType (Proxy :: Proxy k))+            (duckLogicalType (Proxy :: Proxy v))+    duckFromField (FieldMap pairs) = do+        decodedPairs <- traverse decodePair pairs+        pure (Map.fromList decodedPairs)+      where+        decodePair (kfv, vfv) = do+            k <- duckFromField kfv+            v <- duckFromField vfv+            pure (k, v)+    duckFromField other = Left ("duckdb-simple: expected MAP, got " <> show other)++--------------------------------------------------------------------------------+-- Generic machinery++-- | Internal representation used while traversing the generic structure.  We+-- keep both the encoded value and its logical type so we can re-use the same+-- traversal when generating metadata ('genericLogicalType') and when producing+-- concrete values ('genericToFieldValue').+data Encoded+    = EncodedStruct (StructValue FieldValue) (Array Int (StructField LogicalTypeRep))+    | EncodedUnion (UnionValue FieldValue)+    | EncodedNull++encodedValue :: Encoded -> FieldValue+encodedValue = \case+    EncodedStruct sv _ -> FieldStruct sv+    EncodedUnion uv -> FieldUnion uv+    EncodedNull -> FieldNull++-- | Convert a Haskell value (using its generic representation) into a DuckDB 'FieldValue'.+genericToFieldValue :: forall a. (Generic a, GToField (Rep a)) => a -> FieldValue+genericToFieldValue = encodedValue . gToField . from++-- | Extract the logical DuckDB type corresponding to a Haskell value.+genericLogicalType :: forall a. (Generic a, GToField (Rep a)) => Proxy a -> LogicalTypeRep+genericLogicalType _ = gLogicalType (Proxy :: Proxy (Rep a ()))++-- | Decode a DuckDB 'FieldValue' back into a Haskell value using its generic representation.+genericFromFieldValue :: forall a. (Generic a, GFromField (Rep a)) => FieldValue -> Either String a+genericFromFieldValue fv = to <$> gFromField fv++-- | Convenience helpers that project out structured values directly.+genericToStructValue :: forall a. (Generic a, GToField (Rep a)) => a -> Maybe (StructValue FieldValue)+genericToStructValue value =+    case gToField (from value) of+        EncodedStruct sv _ -> Just sv+        EncodedNull -> Just emptyStruct+        _ -> Nothing+  where+    emptyStruct =+        StructValue+            { structValueFields = listArray (0, -1) []+            , structValueTypes = listArray (0, -1) []+            , structValueIndex = Map.empty+            }++genericToUnionValue :: forall a. (Generic a, GToField (Rep a)) => a -> Maybe (UnionValue FieldValue)+genericToUnionValue value =+    case gToField (from value) of+        EncodedUnion uv -> Just uv+        _ -> Nothing++-- | Wrapper for deriving-via so that @instance ToField (ViaDuckDB a)@ picks up+-- the generic encoding provided by this module.+newtype ViaDuckDB a = ViaDuckDB { getViaDuckDB :: a }++-- Type family to decide whether a representation is a sum.+-- | Type family evaluating to 'True for sum-of-constructors generic+-- representations.  We use this to select the appropriate encoding strategy.+type family IsSum f :: Bool where+    IsSum (f :+: g) = 'True+    IsSum (M1 D _ f) = IsSum f+    IsSum (M1 C _ f) = IsSum f+    IsSum _ = 'False++-- | Generic encoding to the intermediate 'Encoded' representation.  Every+-- instance must also supply the corresponding logical type description.+class GToField f where+    gToField :: f p -> Encoded+    gLogicalType :: Proxy (f p) -> LogicalTypeRep++instance (GToField' (IsSum f) f) => GToField f where+    gToField = gToField' (Proxy :: Proxy (IsSum f))+    gLogicalType _ = gLogicalType' (Proxy :: Proxy (IsSum f)) (Proxy :: Proxy f)++-- | Helper class that splits the product and sum handling using the 'IsSum'+-- type family.  We specialise on products ('False) and sums ('True) to keep+-- the core logic small and easy to reason about.+class GToField' (isSum :: Bool) f where+    gToField' :: Proxy isSum -> f p -> Encoded+    gLogicalType' :: Proxy isSum -> Proxy f -> LogicalTypeRep++-- Products (single constructor records)+-- | Product encoding: single-constructor datatypes become STRUCT values.+instance (GStruct f) => GToField' 'False (M1 D meta (M1 C c f)) where+    gToField' _ (M1 (M1 inner)) =+        let comps = gStructValues inner+            typeComps = gStructTypes (Proxy :: Proxy (f p))+         in case comps of+                [] -> EncodedNull+                _ ->+                    let names = resolveNames (zip progIndices (map fcName comps))+                        valueArray = listArrayFrom names (map fcValue comps)+                        typeArray = listArrayFrom names (map fcValue typeComps)+                        indexMap = Map.fromList (zip names [0 ..])+                     in EncodedStruct+                            StructValue+                                { structValueFields = valueArray+                                , structValueTypes = typeArray+                                , structValueIndex = indexMap+                                }+                            typeArray+      where+        progIndices = [0 :: Int ..]+    gLogicalType' _ _ =+        let typeComps = gStructTypes (Proxy :: Proxy (f p))+            names = resolveNames (zip [0 :: Int ..] (map fcName typeComps))+            typeArray = listArrayFrom names (map fcValue typeComps)+         in LogicalTypeStruct typeArray++-- Sums (encode as union)+-- | Sum encoding: multi-constructor datatypes become UNION values.+instance (GSum f) => GToField' 'True (M1 D meta f) where+    gToField' _ (M1 value) =+        let members = gSumMembers (Proxy :: Proxy (f p))+            membersArray =+                case members of+                    [] -> listArray (0, -1) []+                    _ -> listArray (0, length members - 1) members+            (idx, payload) = gSumEncode value+            label = unionMemberName (members !! idx)+         in EncodedUnion+                UnionValue+                    { unionValueIndex = fromIntegral idx+                    , unionValueLabel = label+                    , unionValuePayload = payload+                    , unionValueMembers = membersArray+                    }+    gLogicalType' _ _ =+        let members = gSumMembers (Proxy :: Proxy (f p))+            membersArray =+                case members of+                    [] -> listArray (0, -1) []+                    _ -> listArray (0, length members - 1) members+         in LogicalTypeUnion membersArray++--------------------------------------------------------------------------------+-- GStruct: products++data FieldComponent a = FieldComponent+    { fcName :: Maybe Text+    , fcValue :: a+    }++resolveNames :: [(Int, Maybe Text)] -> [Text]+-- | Assign canonical names to struct fields.  We preserve any selector names+-- provided by GHC.Generics and fall back to @fieldN@ for positional products.+resolveNames =+    map pick+  where+    pick (_, Just n) = n+    pick (idx, Nothing) = Text.pack ("field" <> show (idx + 1))++-- | Helper that builds an 'Array' of struct fields from parallel lists of names+-- and payloads.+listArrayFrom :: [Text] -> [b] -> Array Int (StructField b)+listArrayFrom names values =+    case values of+        [] -> listArray (0, -1) []+        _ ->+            listArray+                (0, length values - 1)+                (zipWith (\n v -> StructField{structFieldName = n, structFieldValue = v}) names values)++-- | Collect the components (values and types) of a product.  Implementations+-- produce parallel lists so we can zip them during encoding and decoding.+class GStruct f where+    gStructValues :: f p -> [FieldComponent FieldValue]+    gStructTypes :: Proxy (f p) -> [FieldComponent LogicalTypeRep]++instance GStruct U1 where+    gStructValues _ = []+    gStructTypes _ = []++instance (GStruct a, GStruct b) => GStruct (a :*: b) where+    gStructValues (a :*: b) = gStructValues a ++ gStructValues b+    gStructTypes _ = gStructTypes (Proxy :: Proxy (a p)) ++ gStructTypes (Proxy :: Proxy (b p))++instance (Selector s, DuckValue a) => GStruct (M1 S s (K1 i a)) where+    gStructValues m@(M1 (K1 x)) =+        let name = toMaybe (selName m)+         in [FieldComponent name (duckToField x)]+    gStructTypes _ =+        let raw = selName (undefined :: M1 S s (K1 i a) ())+            name = toMaybe raw+         in [FieldComponent name (duckLogicalType (Proxy :: Proxy a))]++instance (GStruct f) => GStruct (M1 C c f) where+    gStructValues (M1 x) = gStructValues x+    gStructTypes _ = gStructTypes (Proxy :: Proxy (f p))++toMaybe :: String -> Maybe Text+toMaybe name+    | null name = Nothing+    | otherwise = Just (Text.pack name)++--------------------------------------------------------------------------------+-- Sums (unions)++-- | Sum type encoding.  We gather the metadata ('gSumMembers'), convert a value+-- to its discriminant and payload ('gSumEncode'), and provide the inverse+-- ('gSumDecode').+class GSum f where+    gSumMembers :: Proxy (f p) -> [UnionMemberType]+    gSumEncode :: f p -> (Int, FieldValue)+    gSumDecode :: Int -> FieldValue -> Either String (f p)++instance (GSum a, GSum b) => GSum (a :+: b) where+    gSumMembers _ = gSumMembers (Proxy :: Proxy (a p)) ++ gSumMembers (Proxy :: Proxy (b p))+    gSumEncode (L1 x) = gSumEncode x+    gSumEncode (R1 x) =+        let leftCount = length (gSumMembers (Proxy :: Proxy (a p)))+            (idx, payload) = gSumEncode x+         in (idx + leftCount, payload)+    gSumDecode idx payload =+        let leftCount = length (gSumMembers (Proxy :: Proxy (a p)))+         in if idx < leftCount+                then L1 <$> gSumDecode idx payload+                else R1 <$> gSumDecode (idx - leftCount) payload++instance (Constructor c, GStruct f, GStructDecode f) => GSum (M1 C c f) where+    gSumMembers _ =+        [ UnionMemberType+            { unionMemberName = Text.pack (conName (undefined :: M1 C c f p))+            , unionMemberType =+                let typeComps = gStructTypes (Proxy :: Proxy (f p))+                    names = resolveNames (zip [0 :: Int ..] (map fcName typeComps))+                 in LogicalTypeStruct (listArrayFrom names (map fcValue typeComps))+            }+        ]+    gSumEncode (M1 x) =+        case gStructValues x of+            [] -> (0, FieldNull)+            comps ->+                let typeComps = gStructTypes (Proxy :: Proxy (f p))+                    names = resolveNames (zip [0 :: Int ..] (map fcName comps))+                    valueArray = listArrayFrom names (map fcValue comps)+                    typeArray = listArrayFrom names (map fcValue typeComps)+                    indexMap = Map.fromList (zip names [0 ..])+                 in (0, FieldStruct StructValue{structValueFields = valueArray, structValueTypes = typeArray, structValueIndex = indexMap})+    gSumDecode idx payload+        | idx /= 0 = Left ("duckdb-simple: union tag mismatch (expected 0, got " <> show idx <> ")")+        | otherwise =+            case payload of+                FieldNull -> pure (M1 (gStructNull (Proxy :: Proxy (f p))))+                FieldStruct structVal -> M1 <$> gStructDecodeStruct (Proxy :: Proxy (f p)) structVal+                other -> Left ("duckdb-simple: expected STRUCT payload for union member, got " <> show other)++--------------------------------------------------------------------------------+-- GStructDecode: inverse of GStruct for decoding++-- | Inverse of 'GStruct': decode struct payloads back into a generic product.+class GStructDecode f where+    gStructDecodeStruct :: Proxy (f p) -> StructValue FieldValue -> Either String (f p)+    -- | Construct a null/empty value for a struct type.+    -- This is only valid for U1 (empty structs) and their compositions.+    -- For selectors with actual values, this should never be called in practice+    -- as nullary constructors are represented as U1.+    gStructNull :: Proxy (f p) -> f p+    -- | Consume a prefix of fields from left to right while decoding, returning+    -- the reconstructed value and any remaining fields.+    gStructDecodeList :: Proxy (f p) -> [FieldValue] -> Either String (f p, [FieldValue])++instance GStructDecode U1 where+    gStructDecodeStruct _ structVal =+        if null (elems (structValueFields structVal))+            then Right U1+            else Left ("duckdb-simple: expected empty struct, but got " <> show (length (elems (structValueFields structVal))) <> " field(s)")+    gStructNull _ = U1+    gStructDecodeList _ xs = Right (U1, xs)++instance (GStructDecode a, GStructDecode b) => GStructDecode (a :*: b) where+    gStructDecodeStruct _ structVal = do+        let values = map structFieldValue (elems (structValueFields structVal))+        (leftVal, rest) <- gStructDecodeList (Proxy :: Proxy (a p)) values+        (rightVal, rest') <- gStructDecodeList (Proxy :: Proxy (b p)) rest+        unless (null rest') $+            Left ("duckdb-simple: extra " <> show (length rest') <> " field(s) when decoding struct (too many fields provided)")+        pure (leftVal :*: rightVal)+    gStructNull _ = gStructNull (Proxy :: Proxy (a p)) :*: gStructNull (Proxy :: Proxy (b p))+    gStructDecodeList _ xs = do+        (leftVal, rest) <- gStructDecodeList (Proxy :: Proxy (a p)) xs+        (rightVal, rest') <- gStructDecodeList (Proxy :: Proxy (b p)) rest+        pure (leftVal :*: rightVal, rest')++instance (Selector s, DuckValue a) => GStructDecode (M1 S s (K1 i a)) where+    gStructDecodeStruct _ structVal =+        case map structFieldValue (elems (structValueFields structVal)) of+            [fv] -> M1 . K1 <$> duckFromField fv+            [] -> Left "duckdb-simple: missing struct field (expected 1, got 0)"+            xs -> Left ("duckdb-simple: expected single field struct, but got " <> show (length xs) <> " fields")+    -- IMPOSSIBLE: This should never be called in practice because nullary constructors+    -- are represented as U1, not as selectors with actual field values. A selector (M1 S)+    -- represents a record field that must contain a value, so there's no sensible way to+    -- construct a "null" instance. This method is only needed to satisfy the GStructDecode+    -- typeclass constraint, but in the actual decoding path (gSumDecode), nullary constructors+    -- always take the FieldNull case which constructs U1 directly, never calling gStructNull+    -- on a selector. If this error is ever reached, it indicates a bug in the generic+    -- traversal logic.+    gStructNull _ = error "duckdb-simple: impossible - gStructNull called on selector"+    gStructDecodeList _ [] = Left "duckdb-simple: missing struct field (expected field but list is empty)"+    gStructDecodeList _ (fv : rest) = do+        val <- duckFromField fv+        pure (M1 (K1 val), rest)++instance (GStructDecode f) => GStructDecode (M1 C c f) where+    gStructDecodeStruct _ structVal = M1 <$> gStructDecodeStruct (Proxy :: Proxy (f p)) structVal+    gStructNull _ = M1 (gStructNull (Proxy :: Proxy (f p)))+    gStructDecodeList _ values = do+        (inner, rest) <- gStructDecodeList (Proxy :: Proxy (f p)) values+        pure (M1 inner, rest)++--------------------------------------------------------------------------------+-- GFromField (inverse generic)++-- | Generic decoding entry point mirroring 'GToField'.  This is used both by+-- @genericFromFieldValue@ and the 'Generically' deriving helper.+class GFromField f where+    gFromField :: FieldValue -> Either String (f p)++instance (GFromField' (IsSum f) f) => GFromField f where+    gFromField = gFromField' (Proxy :: Proxy (IsSum f))++class GFromField' (isSum :: Bool) f where+    gFromField' :: Proxy isSum -> FieldValue -> Either String (f p)++instance (GStruct f, GStructDecode f) => GFromField' 'False (M1 D meta (M1 C c f)) where+    gFromField' _ = \case+        FieldNull -> pure (M1 (M1 (gStructNull (Proxy :: Proxy (f p)))))+        FieldStruct sv -> M1 . M1 <$> gStructDecodeStruct (Proxy :: Proxy (f p)) sv+        other -> Left ("duckdb-simple: expected STRUCT value for product type, got " <> show other)++instance (GSum f) => GFromField' 'True (M1 D meta f) where+    gFromField' _ = \case+        FieldUnion uv -> M1 <$> gSumDecode (fromIntegral (unionValueIndex uv)) (unionValuePayload uv)+        other -> Left ("duckdb-simple: expected UNION value for sum type, got " <> show other)++instance GFromField' 'False (M1 D meta U1) where+    gFromField' _ _ = Right (M1 U1)++--------------------------------------------------------------------------------+-- ViaDuckDB instances++-- | The deriving-via version of 'DuckDBColumnType'.  We look at the generic+-- logical type and map it back to a textual name.  The textual names are only+-- used for diagnostics (errors and column metadata).+instance (Generic a, GToField (Rep a)) => DuckDBColumnType (ViaDuckDB a) where+    duckdbColumnTypeFor _ =+        case genericLogicalType (Proxy :: Proxy a) of+            LogicalTypeStruct{} -> Text.pack "STRUCT"+            LogicalTypeUnion{} -> Text.pack "UNION"+            LogicalTypeList{} -> Text.pack "LIST"+            LogicalTypeArray{} -> Text.pack "ARRAY"+            LogicalTypeMap{} -> Text.pack "MAP"+            LogicalTypeScalar dtype -> duckdbTypeToName dtype+            LogicalTypeDecimal{} -> Text.pack "DECIMAL"+            LogicalTypeEnum{} -> Text.pack "ENUM"++-- | Deriving-via 'ToField' instance.  We reuse the helpers above to decide+-- whether the top-level representation is a union, struct, or scalar and then+-- delegate to the existing 'ToField' instances for those composite types.+instance (Generic a, GToField (Rep a)) => ToField (ViaDuckDB a) where+    toField (ViaDuckDB x) =+        case genericToUnionValue x of+            Just unionVal -> toField unionVal+            Nothing ->+                case genericToStructValue x of+                    Just structVal -> toField structVal+                    Nothing ->+                        case genericToFieldValue x of+                            FieldUnion uv -> toField uv+                            FieldStruct sv -> toField sv+                            FieldNull -> toField (Nothing :: Maybe Int)+                            other -> error ("duckdb-simple: unsupported generic encoding " <> show other)++-- | Deriving-via 'FromField' instance.  Errors are rewrapped using the existing+-- 'returnError' helper so callers receive a proper 'ResultError'.+instance (Generic a, GFromField (Rep a), Typeable a) => FromField (ViaDuckDB a) where+    fromField f@Field{fieldValue} =+        case genericFromFieldValue fieldValue of+            Right value -> pure (ViaDuckDB value)+            Left err ->+                returnError ConversionFailed f (Text.pack err)++duckdbTypeToName :: DuckDBType -> Text+-- | Translate a 'DuckDBType' into a textual label for diagnostics and+-- documentation.  This mirrors the naming used in "Database.DuckDB.Simple.ToField".+duckdbTypeToName dtype+    | dtype == DuckDBTypeBoolean = Text.pack "BOOLEAN"+    | dtype == DuckDBTypeTinyInt = Text.pack "TINYINT"+    | dtype == DuckDBTypeSmallInt = Text.pack "SMALLINT"+    | dtype == DuckDBTypeInteger = Text.pack "INTEGER"+    | dtype == DuckDBTypeBigInt = Text.pack "BIGINT"+    | dtype == DuckDBTypeUTinyInt = Text.pack "UTINYINT"+    | dtype == DuckDBTypeUSmallInt = Text.pack "USMALLINT"+    | dtype == DuckDBTypeUInteger = Text.pack "UINTEGER"+    | dtype == DuckDBTypeUBigInt = Text.pack "UBIGINT"+    | dtype == DuckDBTypeFloat = Text.pack "FLOAT"+    | dtype == DuckDBTypeDouble = Text.pack "DOUBLE"+    | dtype == DuckDBTypeVarchar = Text.pack "VARCHAR"+    | dtype == DuckDBTypeBlob = Text.pack "BLOB"+    | dtype == DuckDBTypeDate = Text.pack "DATE"+    | dtype == DuckDBTypeTime = Text.pack "TIME"+    | dtype == DuckDBTypeTimestamp = Text.pack "TIMESTAMP"+    | dtype == DuckDBTypeTimestampTz = Text.pack "TIMESTAMP_TZ"+    | dtype == DuckDBTypeUUID = Text.pack "UUID"+    | dtype == DuckDBTypeInterval = Text.pack "INTERVAL"+    | dtype == DuckDBTypeHugeInt = Text.pack "HUGEINT"+    | dtype == DuckDBTypeUHugeInt = Text.pack "UHUGEINT"+    | dtype == DuckDBTypeBigNum = Text.pack "BIGNUM"+    | dtype == DuckDBTypeTimeTz = Text.pack "TIME_TZ"+    | otherwise = Text.pack (show dtype)++--------------------------------------------------------------------------------+-- DuckDB type constructors (re-exported patterns)++-- These pattern synonyms come from duckdb-ffi; re-exporting to avoid users having to import it.

@@ -0,0 +1,235 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}++module Database.DuckDB.Simple.LogicalRep (+    -- * Structured value helpers+    StructField (..),+    StructValue (..),+    UnionMemberType (..),+    UnionValue (..),+    LogicalTypeRep (..),+    structValueTypeRep,+    unionValueTypeRep,+    logicalTypeToRep,+    logicalTypeFromRep,+    destroyLogicalType,+) where++import Control.Exception (bracket, throwIO)+import Control.Monad (forM, when)+import Data.Array (Array, elems, listArray)+import Data.Map.Strict (Map)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Word (Word16, Word64, Word8)+import Database.DuckDB.FFI+import Foreign.C.String (peekCString, withCString)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Marshal.Array (withArray)+import Foreign.Marshal.Utils (withMany)+import Foreign.Ptr (castPtr, nullPtr)+import Foreign.Storable (poke)++data LogicalTypeRep+    = LogicalTypeScalar DuckDBType+    | LogicalTypeDecimal !Word8 !Word8+    | LogicalTypeList LogicalTypeRep+    | LogicalTypeArray LogicalTypeRep !Word64+    | LogicalTypeMap LogicalTypeRep LogicalTypeRep+    | LogicalTypeStruct !(Array Int (StructField LogicalTypeRep))+    | LogicalTypeUnion !(Array Int UnionMemberType)+    | LogicalTypeEnum !(Array Int Text)+    deriving (Eq, Show)++data StructField a = StructField+    { structFieldName :: !Text+    , structFieldValue :: !a+    }+    deriving (Eq, Show)++data StructValue a = StructValue+    { structValueFields :: !(Array Int (StructField a))+    , structValueTypes :: !(Array Int (StructField LogicalTypeRep))+    , structValueIndex :: !(Map Text Int)+    }+    deriving (Eq, Show)++data UnionMemberType = UnionMemberType+    { unionMemberName :: !Text+    , unionMemberType :: !LogicalTypeRep+    }+    deriving (Eq, Show)++data UnionValue a = UnionValue+    { unionValueIndex :: !Word16+    , unionValueLabel :: !Text+    , unionValuePayload :: !a+    , unionValueMembers :: !(Array Int UnionMemberType)+    }+    deriving (Eq, Show)++structValueTypeRep :: StructValue a -> LogicalTypeRep+structValueTypeRep StructValue{structValueTypes} = LogicalTypeStruct structValueTypes++unionValueTypeRep :: UnionValue a -> LogicalTypeRep+unionValueTypeRep UnionValue{unionValueMembers} = LogicalTypeUnion unionValueMembers++destroyLogicalType :: DuckDBLogicalType -> IO ()+destroyLogicalType logical =+    alloca \ptr -> do+        poke ptr logical+        c_duckdb_destroy_logical_type ptr++logicalTypeToRep :: DuckDBLogicalType -> IO LogicalTypeRep+logicalTypeToRep logical = do+    dtype <- c_duckdb_get_type_id logical+    case dtype of+        DuckDBTypeStruct -> do+            childCountRaw <- c_duckdb_struct_type_child_count logical+            childCount <- word64ToInt (Text.pack "struct child count") childCountRaw+            fields <-+                forM [0 .. childCount - 1] \idx -> do+                    namePtr <- c_duckdb_struct_type_child_name logical (fromIntegral idx)+                    when (namePtr == nullPtr) $+                        throwIO (userError "duckdb-simple: struct child name is null")+                    name <- Text.pack <$> peekCString namePtr+                    c_duckdb_free (castPtr namePtr)+                    childLogical <- c_duckdb_struct_type_child_type logical (fromIntegral idx)+                    childRep <-+                        bracket (pure childLogical) destroyLogicalType logicalTypeToRep+                    pure StructField{structFieldName = name, structFieldValue = childRep}+            pure $+                LogicalTypeStruct+                    ( if childCount <= 0+                        then listArray (0, -1) []+                        else listArray (0, childCount - 1) fields+                    )+        DuckDBTypeUnion -> do+            memberCountRaw <- c_duckdb_union_type_member_count logical+            memberCount <- word64ToInt (Text.pack "union member count") memberCountRaw+            members <-+                forM [0 .. memberCount - 1] \idx -> do+                    namePtr <- c_duckdb_union_type_member_name logical (fromIntegral idx)+                    when (namePtr == nullPtr) $+                        throwIO (userError "duckdb-simple: union member name is null")+                    name <- Text.pack <$> peekCString namePtr+                    c_duckdb_free (castPtr namePtr)+                    memberLogical <- c_duckdb_union_type_member_type logical (fromIntegral idx)+                    memberRep <-+                        bracket (pure memberLogical) destroyLogicalType logicalTypeToRep+                    pure UnionMemberType{unionMemberName = name, unionMemberType = memberRep}+            pure $+                LogicalTypeUnion+                    ( if memberCount <= 0+                        then listArray (0, -1) []+                        else listArray (0, memberCount - 1) members+                    )+        DuckDBTypeList -> do+            childLogical <- c_duckdb_list_type_child_type logical+            childRep <- bracket (pure childLogical) destroyLogicalType logicalTypeToRep+            pure (LogicalTypeList childRep)+        DuckDBTypeArray -> do+            childLogical <- c_duckdb_array_type_child_type logical+            childRep <- bracket (pure childLogical) destroyLogicalType logicalTypeToRep+            size <- c_duckdb_array_type_array_size logical+            pure (LogicalTypeArray childRep size)+        DuckDBTypeMap -> do+            keyLogical <- c_duckdb_map_type_key_type logical+            valueLogical <- c_duckdb_map_type_value_type logical+            keyRep <- bracket (pure keyLogical) destroyLogicalType logicalTypeToRep+            valueRep <- bracket (pure valueLogical) destroyLogicalType logicalTypeToRep+            pure (LogicalTypeMap keyRep valueRep)+        DuckDBTypeDecimal -> do+            width <- c_duckdb_decimal_width logical+            scale <- c_duckdb_decimal_scale logical+            pure (LogicalTypeDecimal width scale)+        DuckDBTypeEnum -> do+            dictSize <- c_duckdb_enum_dictionary_size logical+            let count = fromIntegral dictSize :: Int+            entries <-+                forM [0 .. count - 1] \idx -> do+                    entryPtr <- c_duckdb_enum_dictionary_value logical (fromIntegral idx)+                    when (entryPtr == nullPtr) $+                        throwIO (userError "duckdb-simple: enum dictionary value is null")+                    entry <- Text.pack <$> peekCString entryPtr+                    c_duckdb_free (castPtr entryPtr)+                    pure entry+            pure $+                LogicalTypeEnum+                    ( if count <= 0+                        then listArray (0, -1) []+                        else listArray (0, count - 1) entries+                    )+        _ ->+            pure (LogicalTypeScalar dtype)++logicalTypeFromRep :: LogicalTypeRep -> IO DuckDBLogicalType+logicalTypeFromRep = \case+    LogicalTypeScalar dtype ->+        c_duckdb_create_logical_type dtype+    LogicalTypeDecimal width scale ->+        c_duckdb_create_decimal_type width scale+    LogicalTypeList elemRep ->+        bracket (logicalTypeFromRep elemRep) destroyLogicalType c_duckdb_create_list_type+    LogicalTypeArray elemRep size ->+        bracket (logicalTypeFromRep elemRep) destroyLogicalType $+            flip c_duckdb_create_array_type size+    LogicalTypeMap keyRep valueRep ->+        bracket (logicalTypeFromRep keyRep) destroyLogicalType \keyType ->+            bracket (logicalTypeFromRep valueRep) destroyLogicalType $+                        c_duckdb_create_map_type keyType+    LogicalTypeStruct fieldArray -> do+        let fields = elems fieldArray+            count = length fields+        if count == 0+            then c_duckdb_create_struct_type nullPtr nullPtr 0+            else do+                childTypes <- mapM (logicalTypeFromRep . structFieldValue) fields+                let names = map (Text.unpack . structFieldName) fields+                result <-+                    withMany withCString names \namePtrs ->+                        withArray namePtrs \nameArray ->+                            withArray childTypes \typeArray ->+                                c_duckdb_create_struct_type typeArray nameArray (fromIntegral count)+                mapM_ destroyLogicalType childTypes+                pure result+    LogicalTypeUnion memberArray -> do+        let members = elems memberArray+            count = length members+        if count == 0+            then c_duckdb_create_union_type nullPtr nullPtr 0+            else do+                memberTypes <- mapM (logicalTypeFromRep . unionMemberType) members+                let names = map (Text.unpack . unionMemberName) members+                result <-+                    withMany withCString names \namePtrs ->+                        withArray namePtrs \nameArray ->+                            withArray memberTypes \memberPtr ->+                                c_duckdb_create_union_type memberPtr nameArray (fromIntegral count)+                mapM_ destroyLogicalType memberTypes+                pure result+    LogicalTypeEnum dictArray -> do+        let entries = elems dictArray+            count = length entries+        if count == 0+            then c_duckdb_create_enum_type nullPtr 0+            else+                withMany withCString (map Text.unpack entries) \namePtrs ->+                    withArray namePtrs \nameArray ->+                        c_duckdb_create_enum_type nameArray (fromIntegral count)++word64ToInt :: Text -> Word64 -> IO Int+word64ToInt label value =+    let actual = toInteger value+        limit = toInteger (maxBound :: Int)+     in if actual <= limit+            then pure (fromIntegral value)+            else+                throwIO+                    ( userError+                        ( "duckdb-simple: "+                            <> Text.unpack label+                            <> " exceeds Int range"+                        )+                    )

@@ -0,0 +1,582 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE NamedFieldPuns #-}++module Database.DuckDB.Simple.Materialize (+    materializeValue,+) where++import Control.Exception (bracket, throwIO)+import Control.Monad (forM, when)+import qualified Data.ByteString as BS+import Data.Bits (clearBit, shiftL, xor, (.|.))+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Ratio ((%))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TextEncoding+import Data.Array (Array, elems, listArray)+import qualified Data.Map.Strict as Map+import Data.Time.Calendar (Day, fromGregorian)+import Data.Time.Clock (UTCTime (..))+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.Time.LocalTime+    ( LocalTime (..)+    , TimeOfDay (..)+    , minutesToTimeZone+    , utc+    , utcToLocalTime+    )+import qualified Data.UUID as UUID+import Data.Word (Word16, Word32, Word64, Word8)+import Database.DuckDB.FFI+import Database.DuckDB.Simple.FromField+    ( BigNum (..)+    , BitString (..)+    , DecimalValue (..)+    , FieldValue (..)+    , IntervalValue (..)+    , TimeWithZone (..)+    , fromBigNumBytes+    )+import Database.DuckDB.Simple.LogicalRep+    ( LogicalTypeRep (..)+    , StructField (..)+    , StructValue (..)+    , UnionMemberType (..)+    , UnionValue (..)+    , logicalTypeToRep+    )+import Foreign.C.Types (CBool (..))+import Foreign.Marshal.Alloc (alloca)+import Foreign.Ptr (Ptr, castPtr, nullPtr, plusPtr)+import Foreign.Storable (Storable (..), peekByteOff, peekElemOff, pokeByteOff)++data DuckDBListEntry = DuckDBListEntry+    { duckDBListEntryOffset :: !Word64+    , duckDBListEntryLength :: !Word64+    }+    deriving (Eq, Show)++instance Storable DuckDBListEntry where+    sizeOf _ = listEntryWordSize * 2+    alignment _ = alignment (0 :: Word64)+    peek ptr = do+        offset <- peekByteOff ptr 0+        len <- peekByteOff ptr listEntryWordSize+        pure DuckDBListEntry{duckDBListEntryOffset = offset, duckDBListEntryLength = len}+    poke ptr DuckDBListEntry{duckDBListEntryOffset, duckDBListEntryLength} = do+        pokeByteOff ptr 0 duckDBListEntryOffset+        pokeByteOff ptr listEntryWordSize duckDBListEntryLength++listEntryWordSize :: Int+listEntryWordSize = sizeOf (0 :: Word64)++chunkIsRowValid :: Ptr Word64 -> DuckDBIdx -> IO Bool+chunkIsRowValid validity rowIdx+    | validity == nullPtr = pure True+    | otherwise = do+        CBool flag <- c_duckdb_validity_row_is_valid validity rowIdx+        pure (flag /= 0)++chunkDecodeText :: Ptr () -> DuckDBIdx -> IO Text+chunkDecodeText dataPtr rowIdx = do+    let base = castPtr dataPtr :: Ptr Word8+        offset = fromIntegral rowIdx * duckdbStringTSize+        stringPtr = castPtr (base `plusPtr` offset) :: Ptr DuckDBStringT+    len <- c_duckdb_string_t_length stringPtr+    if len == 0+        then pure Text.empty+        else do+            cstr <- c_duckdb_string_t_data stringPtr+            bytes <- BS.packCStringLen (cstr, fromIntegral len)+            pure (TextEncoding.decodeUtf8 bytes)++chunkDecodeBlob :: Ptr () -> DuckDBIdx -> IO BS.ByteString+chunkDecodeBlob dataPtr rowIdx = do+    let base = castPtr dataPtr :: Ptr Word8+        offset = fromIntegral rowIdx * duckdbStringTSize+        stringPtr = castPtr (base `plusPtr` offset) :: Ptr DuckDBStringT+    len <- c_duckdb_string_t_length stringPtr+    if len == 0+        then pure BS.empty+        else do+            ptr <- c_duckdb_string_t_data stringPtr+            BS.packCStringLen (ptr, fromIntegral len)++duckdbStringTSize :: Int+duckdbStringTSize = 16++materializeValue :: DuckDBType -> DuckDBVector -> Ptr () -> Ptr Word64 -> Int -> IO FieldValue+materializeValue dtype vector dataPtr validity rowIdx = do+    let duckIdx = fromIntegral rowIdx :: DuckDBIdx+    valid <- chunkIsRowValid validity duckIdx+    if not valid+        then pure FieldNull+        else case dtype of+            DuckDBTypeBoolean -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr Word8) rowIdx+                pure (FieldBool (raw /= 0))+            DuckDBTypeTinyInt -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr Int8) rowIdx+                pure (FieldInt8 raw)+            DuckDBTypeSmallInt -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr Int16) rowIdx+                pure (FieldInt16 raw)+            DuckDBTypeInteger -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr Int32) rowIdx+                pure (FieldInt32 raw)+            DuckDBTypeBigInt -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr Int64) rowIdx+                pure (FieldInt64 raw)+            DuckDBTypeUTinyInt -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr Word8) rowIdx+                pure (FieldWord8 raw)+            DuckDBTypeUSmallInt -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr Word16) rowIdx+                pure (FieldWord16 raw)+            DuckDBTypeUInteger -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr Word32) rowIdx+                pure (FieldWord32 raw)+            DuckDBTypeUBigInt -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr Word64) rowIdx+                pure (FieldWord64 raw)+            DuckDBTypeFloat -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr Float) rowIdx+                pure (FieldFloat raw)+            DuckDBTypeDouble -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr Double) rowIdx+                pure (FieldDouble raw)+            DuckDBTypeVarchar -> FieldText <$> chunkDecodeText dataPtr duckIdx+            DuckDBTypeUUID -> do+                DuckDBUHugeInt lower upperBiased <- peekElemOff (castPtr dataPtr :: Ptr DuckDBUHugeInt) rowIdx+                let upper = upperBiased `xor` (0x8000000000000000 :: Word64)+                pure (FieldUUID (UUID.fromWords64 (fromIntegral upper) lower))+            DuckDBTypeBlob -> FieldBlob <$> chunkDecodeBlob dataPtr duckIdx+            DuckDBTypeDate -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr Int32) rowIdx+                FieldDate <$> decodeDuckDBDate (DuckDBDate raw)+            DuckDBTypeTime -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTime) rowIdx+                FieldTime <$> decodeDuckDBTime raw+            DuckDBTypeTimeNs -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimeNs) rowIdx+                pure (FieldTime (decodeDuckDBTimeNs raw))+            DuckDBTypeTimeTz -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimeTz) rowIdx+                FieldTimeTZ <$> decodeDuckDBTimeTz raw+            DuckDBTypeTimestamp -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestamp) rowIdx+                FieldTimestamp <$> decodeDuckDBTimestamp raw+            DuckDBTypeTimestampS -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestampS) rowIdx+                FieldTimestamp <$> decodeDuckDBTimestampSeconds raw+            DuckDBTypeTimestampMs -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestampMs) rowIdx+                FieldTimestamp <$> decodeDuckDBTimestampMilliseconds raw+            DuckDBTypeTimestampNs -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestampNs) rowIdx+                FieldTimestamp <$> decodeDuckDBTimestampNanoseconds raw+            DuckDBTypeTimestampTz -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBTimestamp) rowIdx+                FieldTimestampTZ <$> decodeDuckDBTimestampUTCTime raw+            DuckDBTypeInterval -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBInterval) rowIdx+                pure (FieldInterval (intervalValueFromDuckDB raw))+            DuckDBTypeDecimal ->+                bracket+                    (c_duckdb_vector_get_column_type vector)+                    (\lty -> alloca $ \ptr -> poke ptr lty >> c_duckdb_destroy_logical_type ptr)+                    \logical -> do+                        width <- c_duckdb_decimal_width logical+                        scale <- c_duckdb_decimal_scale logical+                        internalTy <- c_duckdb_decimal_internal_type logical+                        rawValue <-+                            case internalTy of+                                DuckDBTypeSmallInt ->+                                    toInteger <$> peekElemOff (castPtr dataPtr :: Ptr Int16) rowIdx+                                DuckDBTypeInteger ->+                                    toInteger <$> peekElemOff (castPtr dataPtr :: Ptr Int32) rowIdx+                                DuckDBTypeBigInt ->+                                    toInteger <$> peekElemOff (castPtr dataPtr :: Ptr Int64) rowIdx+                                DuckDBTypeHugeInt ->+                                    toInteger . duckDBHugeIntToInteger+                                        <$> peekElemOff (castPtr dataPtr :: Ptr DuckDBHugeInt) rowIdx+                                _ ->+                                    error "duckdb-simple: unsupported decimal internal storage type"+                        pure (FieldDecimal (DecimalValue width scale rawValue))+            DuckDBTypeHugeInt -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBHugeInt) rowIdx+                pure (FieldHugeInt (duckDBHugeIntToInteger raw))+            DuckDBTypeUHugeInt -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr DuckDBUHugeInt) rowIdx+                pure (FieldUHugeInt (duckDBUHugeIntToInteger raw))+            DuckDBTypeBit -> do+                let base = castPtr dataPtr :: Ptr Word8+                    offset = fromIntegral rowIdx * duckdbStringTSize+                    stringPtr = castPtr (base `plusPtr` offset) :: Ptr DuckDBStringT+                len <- c_duckdb_string_t_length stringPtr+                ptr <- c_duckdb_string_t_data stringPtr+                bs <- BS.unpack <$> BS.packCStringLen (ptr, fromIntegral len)+                case bs of+                    [] -> pure (FieldBit (BitString 0 BS.empty))+                    [padding] -> pure (FieldBit (BitString padding BS.empty))+                    (paddingByte : b : bits) -> do+                        let cleared = foldl clearBit b [8 - fromIntegral paddingByte .. 7]+                        pure (FieldBit (BitString paddingByte (BS.pack (cleared : bits))))+            DuckDBTypeBigNum -> do+                let base = castPtr dataPtr :: Ptr Word8+                    offset = fromIntegral rowIdx * duckdbStringTSize+                    stringPtr = castPtr (base `plusPtr` offset) :: Ptr DuckDBStringT+                len <- c_duckdb_string_t_length stringPtr+                if len < 3+                    then pure (FieldBigNum (BigNum 0))+                    else do+                        ptr <- c_duckdb_string_t_data stringPtr+                        bytes <- BS.unpack <$> BS.packCStringLen (ptr, fromIntegral len)+                        pure (FieldBigNum (BigNum (fromBigNumBytes bytes)))+            DuckDBTypeArray -> FieldArray <$> decodeArrayElements vector rowIdx+            DuckDBTypeList -> FieldList <$> decodeListElements vector dataPtr rowIdx+            DuckDBTypeMap -> FieldMap <$> decodeMapPairs vector dataPtr rowIdx+            DuckDBTypeStruct ->+                FieldStruct <$> decodeStructValue vector rowIdx+            DuckDBTypeUnion ->+                FieldUnion <$> decodeUnionValue vector dataPtr rowIdx+            DuckDBTypeEnum ->+                bracket+                    (c_duckdb_vector_get_column_type vector)+                    (\lty -> alloca $ \ptr -> poke ptr lty >> c_duckdb_destroy_logical_type ptr)+                    \logical -> do+                        enumInternal <- c_duckdb_enum_internal_type logical+                        case enumInternal of+                            DuckDBTypeUTinyInt ->+                                FieldEnum . fromIntegral <$> peekElemOff (castPtr dataPtr :: Ptr Word8) rowIdx+                            DuckDBTypeUSmallInt ->+                                FieldEnum . fromIntegral <$> peekElemOff (castPtr dataPtr :: Ptr Word16) rowIdx+                            DuckDBTypeUInteger ->+                                FieldEnum <$> peekElemOff (castPtr dataPtr :: Ptr Word32) rowIdx+                            _ ->+                                error "duckdb-simple: unsupported enum internal storage type"+            DuckDBTypeSQLNull ->+                pure FieldNull+            DuckDBTypeStringLiteral -> FieldText <$> chunkDecodeText dataPtr duckIdx+            DuckDBTypeIntegerLiteral -> do+                raw <- peekElemOff (castPtr dataPtr :: Ptr Int64) rowIdx+                pure (FieldInt64 raw)+            DuckDBTypeInvalid ->+                error "duckdb-simple: INVALID type in eager result"+            DuckDBTypeAny ->+                error "duckdb-simple: ANY columns should not appear in results"+            other ->+                error ("duckdb-simple: UNKNOWN type in eager result: " <> show other)++decodeArrayElements :: DuckDBVector -> Int -> IO (Array Int FieldValue)+decodeArrayElements vector rowIdx = do+    arraySize <-+        bracket+            (c_duckdb_vector_get_column_type vector)+            (\logical -> alloca $ \ptr -> poke ptr logical >> c_duckdb_destroy_logical_type ptr)+            \logical -> do+                sizeRaw <- c_duckdb_array_type_array_size logical+                let sizeWord = fromIntegral sizeRaw :: Word64+                ensureWithinIntRange (Text.pack "array size") sizeWord+    childVec <- c_duckdb_array_vector_get_child vector+    when (childVec == nullPtr) $+        throwIO (userError "duckdb-simple: array child vector is null")+    childType <- vectorElementType childVec+    childData <- c_duckdb_vector_get_data childVec+    childValidity <- c_duckdb_vector_get_validity childVec+    let baseIdx = rowIdx * arraySize+    values <-+        forM [0 .. arraySize - 1] \delta ->+            materializeValue childType childVec childData childValidity (baseIdx + delta)+    pure $+        if arraySize <= 0+            then listArray (0, -1) []+            else listArray (0, arraySize - 1) values++decodeListElements :: DuckDBVector -> Ptr () -> Int -> IO [FieldValue]+decodeListElements vector dataPtr rowIdx = do+    entry <- peekElemOff (castPtr dataPtr :: Ptr DuckDBListEntry) rowIdx+    (baseIdx, len) <- listEntryBounds (Text.pack "list") entry+    childVec <- c_duckdb_list_vector_get_child vector+    when (childVec == nullPtr) $+        throwIO (userError "duckdb-simple: list child vector is null")+    childType <- vectorElementType childVec+    childData <- c_duckdb_vector_get_data childVec+    childValidity <- c_duckdb_vector_get_validity childVec+    forM [0 .. len - 1] \delta ->+        materializeValue childType childVec childData childValidity (baseIdx + delta)++decodeMapPairs :: DuckDBVector -> Ptr () -> Int -> IO [(FieldValue, FieldValue)]+decodeMapPairs vector dataPtr rowIdx = do+    entry <- peekElemOff (castPtr dataPtr :: Ptr DuckDBListEntry) rowIdx+    (baseIdx, len) <- listEntryBounds (Text.pack "map") entry+    structVec <- c_duckdb_list_vector_get_child vector+    when (structVec == nullPtr) $+        throwIO (userError "duckdb-simple: map struct vector is null")+    keyVec <- c_duckdb_struct_vector_get_child structVec 0+    valueVec <- c_duckdb_struct_vector_get_child structVec 1+    when (keyVec == nullPtr || valueVec == nullPtr) $+        throwIO (userError "duckdb-simple: map child vectors are null")+    keyType <- vectorElementType keyVec+    valueType <- vectorElementType valueVec+    keyData <- c_duckdb_vector_get_data keyVec+    valueData <- c_duckdb_vector_get_data valueVec+    keyValidity <- c_duckdb_vector_get_validity keyVec+    valueValidity <- c_duckdb_vector_get_validity valueVec+    forM [0 .. len - 1] \delta -> do+        let childIdx = baseIdx + delta+        keyValue <- materializeValue keyType keyVec keyData keyValidity childIdx+        valueValue <- materializeValue valueType valueVec valueData valueValidity childIdx+        pure (keyValue, valueValue)++decodeStructValue :: DuckDBVector -> Int -> IO (StructValue FieldValue)+decodeStructValue vector rowIdx =+    bracket+        (c_duckdb_vector_get_column_type vector)+        (\logical -> alloca $ \ptr -> poke ptr logical >> c_duckdb_destroy_logical_type ptr)+        \logical -> do+            structTypeRep <- logicalTypeToRep logical+            structFields <-+                case structTypeRep of+                    LogicalTypeStruct typeArray -> pure typeArray+                    other ->+                        throwIO+                            ( userError+                                ( "duckdb-simple: expected STRUCT logical type, but saw "+                                    <> show other+                                )+                            )+            let typeList = elems structFields+                count = length typeList+            valueFields <-+                forM (zip [0 .. count - 1] typeList) \(childIdx, StructField{structFieldName}) -> do+                    childVec <- c_duckdb_struct_vector_get_child vector (fromIntegral childIdx)+                    when (childVec == nullPtr) $+                        throwIO (userError "duckdb-simple: struct child vector is null")+                    childType <- vectorElementType childVec+                    childData <- c_duckdb_vector_get_data childVec+                    childValidity <- c_duckdb_vector_get_validity childVec+                    value <- materializeValue childType childVec childData childValidity rowIdx+                    pure StructField{structFieldName, structFieldValue = value}+            let fieldArray =+                    if count <= 0+                        then listArray (0, -1) []+                        else listArray (0, count - 1) valueFields+                indexMap =+                    Map.fromList (zip (map structFieldName typeList) [0 ..])+            pure+                StructValue+                    { structValueFields = fieldArray+                    , structValueTypes = structFields+                    , structValueIndex = indexMap+                    }++decodeUnionValue :: DuckDBVector -> Ptr () -> Int -> IO (UnionValue FieldValue)+decodeUnionValue vector _dataPtr rowIdx =+    bracket+        (c_duckdb_vector_get_column_type vector)+        (\logical -> alloca $ \ptr -> poke ptr logical >> c_duckdb_destroy_logical_type ptr)+        \logical -> do+            unionTypeRep <- logicalTypeToRep logical+            membersArray <-+                case unionTypeRep of+                    LogicalTypeUnion members -> pure members+                    other ->+                        throwIO+                            ( userError+                                ( "duckdb-simple: expected UNION logical type, but saw "+                                    <> show other+                                )+                            )+            let membersList = elems membersArray+                memberCount = length membersList+            tagVec <- c_duckdb_struct_vector_get_child vector 0+            when (tagVec == nullPtr) $+                throwIO (userError "duckdb-simple: union tag vector is null")+            tagType <- vectorElementType tagVec+            tagData <- c_duckdb_vector_get_data tagVec+            tagValidity <- c_duckdb_vector_get_validity tagVec+            tagValue <- materializeValue tagType tagVec tagData tagValidity rowIdx+            memberIdx <-+                case tagValue of+                    FieldWord8 tagWord -> pure (fromIntegral tagWord :: Int)+                    FieldWord16 tagWord -> pure (fromIntegral tagWord :: Int)+                    FieldWord32 tagWord ->+                        if tagWord <= fromIntegral (maxBound :: Word16)+                            then pure (fromIntegral tagWord)+                            else throwIO (userError "duckdb-simple: union tag exceeds Word16 range")+                    FieldWord64 tagWord ->+                        if tagWord <= fromIntegral (maxBound :: Word16)+                            then pure (fromIntegral tagWord)+                            else throwIO (userError "duckdb-simple: union tag exceeds Word16 range")+                    FieldInt8 tagInt+                        | tagInt >= 0 -> pure (fromIntegral tagInt)+                        | otherwise -> throwIO (userError "duckdb-simple: union tag negative")+                    FieldInt16 tagInt+                        | tagInt >= 0 -> pure (fromIntegral tagInt)+                        | otherwise -> throwIO (userError "duckdb-simple: union tag negative")+                    FieldInt32 tagInt+                        | tagInt >= 0 && tagInt <= fromIntegral (maxBound :: Word16) -> pure (fromIntegral tagInt)+                        | tagInt < 0 -> throwIO (userError "duckdb-simple: union tag negative")+                        | otherwise -> throwIO (userError "duckdb-simple: union tag exceeds Word16 range")+                    FieldInt64 tagInt+                        | tagInt >= 0 && tagInt <= fromIntegral (maxBound :: Word16) -> pure (fromIntegral tagInt)+                        | tagInt < 0 -> throwIO (userError "duckdb-simple: union tag negative")+                        | otherwise -> throwIO (userError "duckdb-simple: union tag exceeds Word16 range")+                    FieldNull ->+                        throwIO (userError "duckdb-simple: encountered NULL union tag")+                    other ->+                        throwIO+                            ( userError+                                ( "duckdb-simple: unexpected union tag value "+                                    <> show other+                                )+                            )+            when (memberIdx < 0 || memberIdx >= memberCount) $+                throwIO (userError "duckdb-simple: union tag out of range")+            let selectedMember = membersList !! memberIdx+                memberLabel = unionMemberName selectedMember+            memberVec <- c_duckdb_struct_vector_get_child vector (fromIntegral (memberIdx + 1))+            when (memberVec == nullPtr) $+                throwIO (userError "duckdb-simple: union member vector is null")+            memberType <- vectorElementType memberVec+            memberData <- c_duckdb_vector_get_data memberVec+            memberValidity <- c_duckdb_vector_get_validity memberVec+            payload <- materializeValue memberType memberVec memberData memberValidity rowIdx+            pure+                UnionValue+                    { unionValueIndex = fromIntegral memberIdx+                    , unionValueLabel = memberLabel+                    , unionValuePayload = payload+                    , unionValueMembers = membersArray+                    }++vectorElementType :: DuckDBVector -> IO DuckDBType+vectorElementType vec = do+    logical <- c_duckdb_vector_get_column_type vec+    dtype <- c_duckdb_get_type_id logical+    destroyLogicalType logical+    pure dtype++listEntryBounds :: Text -> DuckDBListEntry -> IO (Int, Int)+listEntryBounds context DuckDBListEntry{duckDBListEntryOffset, duckDBListEntryLength} = do+    base <- ensureWithinIntRange (context <> Text.pack " offset") duckDBListEntryOffset+    len <- ensureWithinIntRange (context <> Text.pack " length") duckDBListEntryLength+    let maxInt = toInteger (maxBound :: Int)+        upperBound = toInteger base + toInteger len - 1+    when (len > 0 && upperBound > maxInt) $+        throwIO (userError ("duckdb-simple: " <> Text.unpack context <> " bounds exceed Int range"))+    pure (base, len)++ensureWithinIntRange :: Text -> Word64 -> IO Int+ensureWithinIntRange context value =+    let actual = toInteger value+        limit = toInteger (maxBound :: Int)+     in if actual <= limit+            then pure (fromInteger actual)+            else throwIO (userError ("duckdb-simple: " <> Text.unpack context <> " exceeds Int range"))++decodeDuckDBDate :: DuckDBDate -> IO Day+decodeDuckDBDate raw =+    alloca $ \ptr -> do+        c_duckdb_from_date raw ptr+        dateStruct <- peek ptr+        pure (dateStructToDay dateStruct)++decodeDuckDBTime :: DuckDBTime -> IO TimeOfDay+decodeDuckDBTime raw =+    alloca $ \ptr -> do+        c_duckdb_from_time raw ptr+        timeStruct <- peek ptr+        pure (timeStructToTimeOfDay timeStruct)++decodeDuckDBTimestamp :: DuckDBTimestamp -> IO LocalTime+decodeDuckDBTimestamp raw =+    alloca $ \ptr -> do+        c_duckdb_from_timestamp raw ptr+        DuckDBTimestampStruct{duckDBTimestampStructDate = dateStruct, duckDBTimestampStructTime = timeStruct} <- peek ptr+        pure+            LocalTime+                { localDay = dateStructToDay dateStruct+                , localTimeOfDay = timeStructToTimeOfDay timeStruct+                }++decodeDuckDBTimeNs :: DuckDBTimeNs -> TimeOfDay+decodeDuckDBTimeNs (DuckDBTimeNs nanos) =+    let (hours, remainderHours) = nanos `divMod` (60 * 60 * 1000000000)+        (minutes, remainderMinutes) = remainderHours `divMod` (60 * 1000000000)+        (seconds, fractionalNanos) = remainderMinutes `divMod` 1000000000+        fractional = fromRational (toInteger fractionalNanos % 1000000000)+        totalSeconds = fromIntegral seconds + fractional+     in TimeOfDay+            (fromIntegral hours)+            (fromIntegral minutes)+            totalSeconds++decodeDuckDBTimeTz :: DuckDBTimeTz -> IO TimeWithZone+decodeDuckDBTimeTz raw =+    alloca $ \ptr -> do+        c_duckdb_from_time_tz raw ptr+        DuckDBTimeTzStruct{duckDBTimeTzStructTime = timeStruct, duckDBTimeTzStructOffset = offset} <- peek ptr+        let timeOfDay = timeStructToTimeOfDay timeStruct+            minutes = fromIntegral offset `div` 60+            zone = minutesToTimeZone minutes+        pure TimeWithZone{timeWithZoneTime = timeOfDay, timeWithZoneZone = zone}++decodeDuckDBTimestampSeconds :: DuckDBTimestampS -> IO LocalTime+decodeDuckDBTimestampSeconds (DuckDBTimestampS seconds) =+    decodeDuckDBTimestamp (DuckDBTimestamp (seconds * 1000000))++decodeDuckDBTimestampMilliseconds :: DuckDBTimestampMs -> IO LocalTime+decodeDuckDBTimestampMilliseconds (DuckDBTimestampMs millis) =+    decodeDuckDBTimestamp (DuckDBTimestamp (millis * 1000))++decodeDuckDBTimestampNanoseconds :: DuckDBTimestampNs -> IO LocalTime+decodeDuckDBTimestampNanoseconds (DuckDBTimestampNs nanos) = do+    let utcTime = posixSecondsToUTCTime (fromRational (toInteger nanos % 1000000000))+    pure (utcToLocalTime utc utcTime)++decodeDuckDBTimestampUTCTime :: DuckDBTimestamp -> IO UTCTime+decodeDuckDBTimestampUTCTime (DuckDBTimestamp micros) =+    pure (posixSecondsToUTCTime (fromRational (toInteger micros % 1000000)))++intervalValueFromDuckDB :: DuckDBInterval -> IntervalValue+intervalValueFromDuckDB DuckDBInterval{duckDBIntervalMonths, duckDBIntervalDays, duckDBIntervalMicros} =+    IntervalValue+        { intervalMonths = duckDBIntervalMonths+        , intervalDays = duckDBIntervalDays+        , intervalMicros = duckDBIntervalMicros+        }++duckDBHugeIntToInteger :: DuckDBHugeInt -> Integer+duckDBHugeIntToInteger DuckDBHugeInt{duckDBHugeIntLower, duckDBHugeIntUpper} =+    (fromIntegral duckDBHugeIntUpper `shiftL` 64) .|. fromIntegral duckDBHugeIntLower++duckDBUHugeIntToInteger :: DuckDBUHugeInt -> Integer+duckDBUHugeIntToInteger DuckDBUHugeInt{duckDBUHugeIntLower, duckDBUHugeIntUpper} =+    (fromIntegral duckDBUHugeIntUpper `shiftL` 64) .|. fromIntegral duckDBUHugeIntLower++destroyLogicalType :: DuckDBLogicalType -> IO ()+destroyLogicalType logicalType =+    alloca $ \ptr -> do+        poke ptr logicalType+        c_duckdb_destroy_logical_type ptr++dateStructToDay :: DuckDBDateStruct -> Day+dateStructToDay DuckDBDateStruct{duckDBDateStructYear, duckDBDateStructMonth, duckDBDateStructDay} =+    fromGregorian+        (fromIntegral duckDBDateStructYear)+        (fromIntegral duckDBDateStructMonth)+        (fromIntegral duckDBDateStructDay)++timeStructToTimeOfDay :: DuckDBTimeStruct -> TimeOfDay+timeStructToTimeOfDay DuckDBTimeStruct{duckDBTimeStructHour, duckDBTimeStructMinute, duckDBTimeStructSecond, duckDBTimeStructMicros} =+    let secondsInt = fromIntegral duckDBTimeStructSecond :: Integer+        micros = fromIntegral duckDBTimeStructMicros :: Integer+        fractional = fromRational (micros % 1000000)+        totalSeconds = fromInteger secondsInt + fractional+     in TimeOfDay+            (fromIntegral duckDBTimeStructHour)+            (fromIntegral duckDBTimeStructMinute)+            totalSeconds

@@ -1,7 +1,7 @@ {-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -24,20 +24,31 @@ ) where  import Control.Exception (bracket, throwIO)-import Control.Monad (when)-import Data.Bits (complement)+import Control.Monad (when, zipWithM)+import Data.Bits (complement, (.&.), shiftL, shiftR) import qualified Data.ByteString as BS-import Data.Int (Int16, Int32, Int64)+import Data.Array (Array, elems)+import Data.Int (Int8, Int16, Int32, Int64) import Data.Proxy (Proxy (..)) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Foreign as TextForeign import Data.Time.Calendar (Day, toGregorian) import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds)-import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..), timeOfDayToTime, utc, utcToLocalTime)+import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..), TimeZone (..), timeOfDayToTime, timeZoneMinutes, utc, utcToLocalTime) import Data.Word (Word16, Word32, Word64, Word8) import Database.DuckDB.FFI-import Database.DuckDB.Simple.FromField (BigNum (..), toBigNumBytes, BitString(..))+import Database.DuckDB.Simple.FromField (BigNum (..), BitString (..), DecimalValue (..), FieldValue (..), IntervalValue (..), TimeWithZone (..), toBigNumBytes)+import Database.DuckDB.Simple.LogicalRep (+    LogicalTypeRep (..),+    StructField (..),+    StructValue (..),+    UnionMemberType (..),+    UnionValue (..),+    logicalTypeFromRep,+    structValueTypeRep,+    unionValueTypeRep+ ) import Database.DuckDB.Simple.Internal (     SQLError (..),     Statement (..),@@ -48,6 +59,7 @@ import Foreign.C.Types (CDouble (..)) import Foreign.Marshal (fromBool) import Foreign.Marshal.Alloc (alloca)+import Foreign.Marshal.Array (withArray) import Foreign.Ptr (Ptr, castPtr, nullPtr) import Foreign.Storable (poke) import Numeric.Natural (Natural)@@ -65,6 +77,14 @@     , fieldBindingDisplay :: !String     } +class ToDuckValue a where+    toDuckValue :: a -> IO DuckDBValue++valueBinding :: String -> IO DuckDBValue -> FieldBinding+valueBinding display mkValue =+    mkFieldBinding display $ \stmt idx ->+        bindDuckValue stmt idx mkValue+ -- | Types that map to a concrete DuckDB column type when used with 'ToField'. class DuckDBColumnType a where     duckdbColumnTypeFor :: Proxy a -> Text@@ -91,134 +111,62 @@ -- | Types that can be used as positional parameters. class (DuckDBColumnType a) => ToField a where     toField :: a -> FieldBinding+    default toField :: (Show a, ToDuckValue a) => a -> FieldBinding+    toField value = valueBinding (show value) (toDuckValue value)  instance ToField Null where     toField Null = nullBinding "NULL" --instance ToField Bool where-    toField value =-        mkFieldBinding (show value) $ \stmt idx ->-            bindDuckValue stmt idx (c_duckdb_create_bool (if value then 1 else 0))--instance ToField Int where-    toField = intBinding . (fromIntegral :: Int -> Int64)--instance ToField Int16 where-    toField = intBinding . (fromIntegral :: Int16 -> Int64)--instance ToField Int32 where-    toField = intBinding . (fromIntegral :: Int32 -> Int64)--instance ToField Int64 where-    toField = intBinding+instance ToField Bool+instance ToField Int+instance ToField Int8+instance ToField Int16+instance ToField Int32+instance ToField Int64+instance ToField Integer+instance ToField Natural+instance ToField UUID.UUID+instance ToField Word+instance ToField Word8+instance ToField Word16+instance ToField Word32+instance ToField Word64+instance ToField Double+instance ToField Float+instance ToField Text+instance ToField String+instance ToField BitString+instance ToField Day+instance ToField TimeOfDay+instance ToField LocalTime+instance ToField UTCTime  instance ToField BigNum where-    toField = bignumBinding--instance ToField UUID.UUID where-    toField = uuidBinding--instance ToField Integer where-    toField :: Integer -> FieldBinding-    toField = toField . BigNum--instance ToField Natural where-    toField = toField . BigNum . toInteger--instance ToField Word where-    toField value = uint64Binding (fromIntegral value)--instance ToField Word16 where-    toField = uint16Binding--instance ToField Word32 where-    toField = uint32Binding--instance ToField Word64 where-    toField = uint64Binding--instance ToField Word8 where-    toField = uint8Binding--instance ToField Double where-    toField value =-        mkFieldBinding-            (show value)-            \stmt idx ->-                bindDuckValue stmt idx (c_duckdb_create_double (CDouble value))--instance ToField Float where-    toField value =-        mkFieldBinding-            (show value)-            \stmt idx ->-                bindDuckValue stmt idx (c_duckdb_create_double (CDouble (realToFrac value)))+    toField big@(BigNum n) = valueBinding (show n) (bigNumDuckValue big) -instance ToField Text where-    toField txt =-        mkFieldBinding-            (show txt)-            \stmt idx ->-                TextForeign.withCString txt $ \cstr ->-                    bindDuckValue stmt idx (c_duckdb_create_varchar cstr)+instance ToField (StructValue FieldValue) where+    toField structVal =+        valueBinding "<struct>" (structValueDuckValue structVal) -instance ToField String where-    toField str =-        mkFieldBinding-            (show str)-            \stmt idx ->-                TextForeign.withCString (Text.pack str) $ \cstr ->-                    bindDuckValue stmt idx (c_duckdb_create_varchar cstr)+instance ToField (UnionValue FieldValue) where+    toField unionVal =+        let label = Text.unpack (unionValueLabel unionVal)+         in valueBinding ("<union " <> label <> ">") (unionValueDuckValue unionVal)  instance DuckDBColumnType BitString where     duckdbColumnTypeFor _ = "BIT" -instance ToField BitString where-    toField = bitBinding- instance ToField BS.ByteString where     toField bs =-        mkFieldBinding+        valueBinding             ("<blob length=" <> show (BS.length bs) <> ">")-            \stmt idx ->-                BS.useAsCStringLen bs \(ptr, len) ->-                    bindDuckValue stmt idx (c_duckdb_create_blob (castPtr ptr :: Ptr Word8) (fromIntegral len))--instance ToField Day where-    toField day =-        mkFieldBinding-            (show day)-            \stmt idx ->-                bindDuckValue stmt idx $ do-                    duckDate <- encodeDay day-                    c_duckdb_create_date duckDate--instance ToField TimeOfDay where-    toField tod =-        mkFieldBinding-            (show tod)-            \stmt idx ->-                bindDuckValue stmt idx $ do-                    duckTime <- encodeTimeOfDay tod-                    c_duckdb_create_time duckTime--instance ToField LocalTime where-    toField ts =-        mkFieldBinding-            (show ts)-            \stmt idx ->-                bindDuckValue stmt idx $ do-                    duckTimestamp <- encodeLocalTime ts-                    c_duckdb_create_timestamp duckTimestamp+            (toDuckValue bs) -instance ToField UTCTime where-    toField utcTime =-        let FieldBinding{fieldBindingAction = action} = toField (utcToLocalTime utc utcTime)-         in FieldBinding-                { fieldBindingAction = action-                , fieldBindingDisplay = show utcTime-                }+instance (DuckDBColumnType a, ToDuckValue a) => ToField (Array Int a) where+    toField arr =+        valueBinding+            ("<array length=" <> show (length (elems arr)) <> ">")+            (arrayDuckValue arr)  instance (ToField a) => ToField (Maybe a) where     toField Nothing = nullBinding "Nothing"@@ -237,6 +185,10 @@ instance DuckDBColumnType Int where     duckdbColumnTypeFor _ = "BIGINT" +instance DuckDBColumnType Int8 where+    duckdbColumnTypeFor _ = "TINYINT"++ instance DuckDBColumnType Int16 where     duckdbColumnTypeFor _ = "SMALLINT" @@ -300,84 +252,95 @@ instance DuckDBColumnType UTCTime where     duckdbColumnTypeFor _ = "TIMESTAMPTZ" +instance DuckDBColumnType (StructValue FieldValue) where+    duckdbColumnTypeFor _ = "STRUCT"++instance DuckDBColumnType (UnionValue FieldValue) where+    duckdbColumnTypeFor _ = "UNION"+ instance (DuckDBColumnType a) => DuckDBColumnType (Maybe a) where     duckdbColumnTypeFor _ = duckdbColumnTypeFor (Proxy :: Proxy a) --- | Helper for binding 'Null' values.+instance (DuckDBColumnType a) => DuckDBColumnType (Array Int a) where+    duckdbColumnTypeFor _ = duckdbColumnTypeFor (Proxy :: Proxy a) <> Text.pack "[]"+ nullBinding :: String -> FieldBinding-nullBinding repr =-    mkFieldBinding-        repr-        \stmt idx ->-            bindDuckValue stmt idx c_duckdb_create_null_value+nullBinding repr = valueBinding repr nullDuckValue -intBinding :: Int64 -> FieldBinding-intBinding value =-    mkFieldBinding-        (show value)-        \stmt idx ->-            bindDuckValue stmt idx (c_duckdb_create_int64 value)+nullDuckValue :: IO DuckDBValue+nullDuckValue = c_duckdb_create_null_value -uint64Binding :: Word64 -> FieldBinding-uint64Binding value =-    mkFieldBinding-        (show value)-        \stmt idx ->-            bindDuckValue stmt idx (c_duckdb_create_uint64 value)+boolDuckValue :: Bool -> IO DuckDBValue+boolDuckValue value = c_duckdb_create_bool (if value then 1 else 0) -uint32Binding :: Word32 -> FieldBinding-uint32Binding value =-    mkFieldBinding-        (show value)-        \stmt idx ->-            bindDuckValue stmt idx (c_duckdb_create_uint32 value)+int8DuckValue :: Int8 -> IO DuckDBValue+int8DuckValue = c_duckdb_create_int8 -uint16Binding :: Word16 -> FieldBinding-uint16Binding value =-    mkFieldBinding-        (show value)-        \stmt idx ->-            bindDuckValue stmt idx (c_duckdb_create_uint16 value)+int16DuckValue :: Int16 -> IO DuckDBValue+int16DuckValue = c_duckdb_create_int16 -uint8Binding :: Word8 -> FieldBinding-uint8Binding value =-    mkFieldBinding-        (show value)-        \stmt idx ->-            bindDuckValue stmt idx (c_duckdb_create_uint8 value)+int32DuckValue :: Int32 -> IO DuckDBValue+int32DuckValue = c_duckdb_create_int32 -uuidBinding :: UUID.UUID -> FieldBinding-uuidBinding uuid =-    mkFieldBinding-        (show uuid)-        \stmt idx ->-            bindDuckValue stmt idx $-              alloca $ \ptr -> do-                let (upper, lower) = UUID.toWords64 uuid-                poke ptr DuckDBUHugeInt-                    { duckDBUHugeIntLower = lower-                    , duckDBUHugeIntUpper = upper-                    }-                c_duckdb_create_uuid ptr+int64DuckValue :: Int64 -> IO DuckDBValue+int64DuckValue = c_duckdb_create_int64 -bitBinding :: BitString -> FieldBinding-bitBinding (BitString padding bits) =-    mkFieldBinding-        (show (BitString padding bits))-        \stmt idx ->-            let w_padding = (fromIntegral padding :: Word8):BS.unpack bits-            in bindDuckValue stmt idx $-                  if BS.null bits-                        then alloca \ptr -> do-                            poke-                                ptr-                                DuckDBBit-                                    { duckDBBitData = nullPtr-                                    , duckDBBitSize = 0-                                    }-                            c_duckdb_create_bit ptr-                        else-                            BS.useAsCStringLen (BS.pack w_padding) \(rawPtr, len) ->+uint64DuckValue :: Word64 -> IO DuckDBValue+uint64DuckValue = c_duckdb_create_uint64++uint32DuckValue :: Word32 -> IO DuckDBValue+uint32DuckValue = c_duckdb_create_uint32++uint16DuckValue :: Word16 -> IO DuckDBValue+uint16DuckValue = c_duckdb_create_uint16++uint8DuckValue :: Word8 -> IO DuckDBValue+uint8DuckValue = c_duckdb_create_uint8++doubleDuckValue :: Double -> IO DuckDBValue+doubleDuckValue = c_duckdb_create_double . CDouble++floatDuckValue :: Float -> IO DuckDBValue+floatDuckValue = c_duckdb_create_double . CDouble . realToFrac++textDuckValue :: Text -> IO DuckDBValue+textDuckValue txt =+    TextForeign.withCString txt c_duckdb_create_varchar++stringDuckValue :: String -> IO DuckDBValue+stringDuckValue = textDuckValue . Text.pack++blobDuckValue :: BS.ByteString -> IO DuckDBValue+blobDuckValue bs =+    BS.useAsCStringLen bs \(ptr, len) ->+        c_duckdb_create_blob (castPtr ptr :: Ptr Word8) (fromIntegral len)++uuidDuckValue :: UUID.UUID -> IO DuckDBValue+uuidDuckValue uuid =+    alloca $ \ptr -> do+        let (upper, lower) = UUID.toWords64 uuid+        poke ptr+            DuckDBUHugeInt+                { duckDBUHugeIntLower = lower+                , duckDBUHugeIntUpper = upper+                }+        c_duckdb_create_uuid ptr++bitDuckValue :: BitString -> IO DuckDBValue+bitDuckValue (BitString padding bits) =+    let withPacked action =+            if BS.null bits+                then alloca \ptr -> do+                    poke+                        ptr+                        DuckDBBit+                            { duckDBBitData = nullPtr+                            , duckDBBitSize = 0+                            }+                    action ptr+                else+                    let payload = BS.pack ((fromIntegral padding :: Word8) : BS.unpack bits)+                     in BS.useAsCStringLen payload \(rawPtr, len) ->                             alloca \ptr -> do                                 poke                                     ptr@@ -385,40 +348,453 @@                                         { duckDBBitData = castPtr rawPtr                                         , duckDBBitSize = fromIntegral len                                         }-                                c_duckdb_create_bit ptr+                                action ptr+     in withPacked c_duckdb_create_bit -bignumBinding :: BigNum -> FieldBinding-bignumBinding (BigNum big) =-    mkFieldBinding-        (show big)-        \stmt idx ->-            bindDuckValue stmt idx $-                let neg = fromBool (big < 0)-                    big_num_bytes =-                        BS.pack $-                            if big < 0-                                then map complement (drop 3 $ toBigNumBytes big)-                                else drop 3 $ toBigNumBytes big-                 in if BS.null big_num_bytes-                        then alloca \ptr -> do-                            poke-                                ptr-                                DuckDBBignum-                                    { duckDBBignumData = nullPtr-                                    , duckDBBignumSize = 0-                                    , duckDBBignumIsNegative = neg-                                    }-                            c_duckdb_create_bignum ptr-                        else BS.useAsCStringLen big_num_bytes \(rawPtr, len) ->-                            alloca \ptr -> do-                                poke-                                    ptr-                                    DuckDBBignum-                                        { duckDBBignumData = castPtr rawPtr-                                        , duckDBBignumSize = fromIntegral len-                                        , duckDBBignumIsNegative = neg-                                        }-                                c_duckdb_create_bignum ptr+bigNumDuckValue :: BigNum -> IO DuckDBValue+bigNumDuckValue (BigNum big) =+    let neg = fromBool (big < 0)+        payload =+            BS.pack $+                if big < 0+                    then map complement (drop 3 $ toBigNumBytes big)+                    else drop 3 $ toBigNumBytes big+        withPayload action =+            if BS.null payload+                then alloca \ptr -> do+                    poke+                        ptr+                        DuckDBBignum+                            { duckDBBignumData = nullPtr+                            , duckDBBignumSize = 0+                            , duckDBBignumIsNegative = neg+                            }+                    action ptr+                else BS.useAsCStringLen payload \(rawPtr, len) ->+                    alloca \ptr -> do+                        poke+                            ptr+                            DuckDBBignum+                                { duckDBBignumData = castPtr rawPtr+                                , duckDBBignumSize = fromIntegral len+                                , duckDBBignumIsNegative = neg+                                }+                        action ptr+     in withPayload c_duckdb_create_bignum++dayDuckValue :: Day -> IO DuckDBValue+dayDuckValue day = do+    duckDate <- encodeDay day+    c_duckdb_create_date duckDate++timeOfDayDuckValue :: TimeOfDay -> IO DuckDBValue+timeOfDayDuckValue tod = do+    duckTime <- encodeTimeOfDay tod+    c_duckdb_create_time duckTime++localTimeDuckValue :: LocalTime -> IO DuckDBValue+localTimeDuckValue ts = do+    duckTimestamp <- encodeLocalTime ts+    c_duckdb_create_timestamp duckTimestamp++utcTimeDuckValue :: UTCTime -> IO DuckDBValue+utcTimeDuckValue utcTime =+    let local = utcToLocalTime utc utcTime+     in localTimeDuckValue local++arrayDuckValue ::+    forall a.+    (DuckDBColumnType a, ToDuckValue a) =>+    Array Int a ->+    IO DuckDBValue+arrayDuckValue arr =+    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++structValueDuckValue :: StructValue FieldValue -> IO DuckDBValue+structValueDuckValue StructValue{structValueFields, structValueTypes, structValueIndex = _} = do+    let valueFields = elems structValueFields+        typeFields = elems structValueTypes+        typeNames = map structFieldName typeFields+        valueNames = map structFieldName valueFields+    when (length valueFields /= length typeFields) $+        throwIO (userError "duckdb-simple: struct value/type arity mismatch")+    when (typeNames /= valueNames) $+        throwIO (userError "duckdb-simple: struct value/type field names mismatch")+    childValues <-+        zipWithM+            (\StructField{structFieldValue = typeRep} StructField{structFieldValue = fieldVal} ->+                fieldValueWithTypeDuckValue typeRep fieldVal+            )+            typeFields+            valueFields+    structLogical <- logicalTypeFromRep (LogicalTypeStruct structValueTypes)+    result <-+        withDuckValues childValues $ c_duckdb_create_struct_value structLogical+    mapM_ destroyValue childValues+    destroyLogicalType structLogical+    pure result++unionValueDuckValue :: UnionValue FieldValue -> IO DuckDBValue+unionValueDuckValue UnionValue{unionValueIndex, unionValuePayload, unionValueMembers} = do+    let membersList = elems unionValueMembers+        idx = fromIntegral unionValueIndex :: Int+        memberCount = length membersList+    when (idx < 0 || idx >= memberCount) $+        throwIO (userError "duckdb-simple: union value tag out of range")+    let UnionMemberType{unionMemberType = memberType} = membersList !! idx+    payloadValue <- fieldValueWithTypeDuckValue memberType unionValuePayload+    unionLogical <- logicalTypeFromRep (LogicalTypeUnion unionValueMembers)+    result <- c_duckdb_create_union_value unionLogical (fromIntegral unionValueIndex) payloadValue+    destroyValue payloadValue+    destroyLogicalType unionLogical+    pure result++fieldValueWithTypeDuckValue :: LogicalTypeRep -> FieldValue -> IO DuckDBValue+fieldValueWithTypeDuckValue _ FieldNull = nullDuckValue+fieldValueWithTypeDuckValue rep value =+    case rep of+        LogicalTypeScalar dtype -> scalarFieldValueDuckValue dtype value+        LogicalTypeDecimal width scale ->+            case value of+                FieldDecimal decVal@DecimalValue{decimalWidth, decimalScale}+                    | decimalWidth == width && decimalScale == scale -> decimalDuckValue decVal+                    | otherwise -> throwIO (userError "duckdb-simple: decimal value metadata mismatch")+                other -> typeMismatch "DECIMAL" other+        LogicalTypeList elemRep ->+            case value of+                FieldList elemsList -> do+                    childLogical <- logicalTypeFromRep elemRep+                    values <- mapM (fieldValueWithTypeDuckValue elemRep) elemsList+                    result <-+                        withDuckValues values \ptr ->+                            c_duckdb_create_list_value childLogical ptr (fromIntegral (length elemsList))+                    mapM_ destroyValue values+                    destroyLogicalType childLogical+                    pure result+                other -> typeMismatch "LIST" other+        LogicalTypeArray elemRep size ->+            case value of+                FieldArray arr -> do+                    let elemsList = elems arr+                        actualCount = length elemsList+                    when (fromIntegral actualCount /= size) $+                        throwIO (userError "duckdb-simple: array length mismatch")+                    childLogical <- logicalTypeFromRep elemRep+                    values <- mapM (fieldValueWithTypeDuckValue elemRep) elemsList+                    result <-+                        withDuckValues values \ptr ->+                            c_duckdb_create_array_value childLogical ptr (fromIntegral actualCount)+                    mapM_ destroyValue values+                    destroyLogicalType childLogical+                    pure result+                other -> typeMismatch "ARRAY" other+        LogicalTypeMap keyRep valueRep ->+            case value of+                FieldMap pairs -> do+                    let count = length pairs+                    keyValues <- mapM (fieldValueWithTypeDuckValue keyRep . fst) pairs+                    valValues <- mapM (fieldValueWithTypeDuckValue valueRep . snd) pairs+                    mapLogical <- logicalTypeFromRep (LogicalTypeMap keyRep valueRep)+                    result <-+                        withDuckValues keyValues \keyPtr ->+                            withDuckValues valValues \valPtr ->+                                c_duckdb_create_map_value mapLogical keyPtr valPtr (fromIntegral count)+                    mapM_ destroyValue keyValues+                    mapM_ destroyValue valValues+                    destroyLogicalType mapLogical+                    pure result+                other -> typeMismatch "MAP" other+        LogicalTypeStruct structRep ->+            case value of+                FieldStruct structVal+                    | structValueTypeRep structVal == LogicalTypeStruct structRep -> structValueDuckValue structVal+                    | otherwise -> throwIO (userError "duckdb-simple: struct value type mismatch")+                other -> typeMismatch "STRUCT" other+        LogicalTypeUnion unionRep ->+            case value of+                FieldUnion unionVal+                    | unionValueTypeRep unionVal == LogicalTypeUnion unionRep -> unionValueDuckValue unionVal+                    | otherwise -> throwIO (userError "duckdb-simple: union value type mismatch")+                other -> typeMismatch "UNION" other+        LogicalTypeEnum dict ->+            case value of+                FieldEnum enumIdx -> enumDuckValue dict enumIdx+                other -> typeMismatch "ENUM" other++scalarFieldValueDuckValue :: DuckDBType -> FieldValue -> IO DuckDBValue+scalarFieldValueDuckValue dtype value =+    case (dtype, value) of+        (DuckDBTypeBoolean, FieldBool b) -> boolDuckValue b+        (DuckDBTypeTinyInt, FieldInt8 i) -> int8DuckValue i+        (DuckDBTypeSmallInt, FieldInt16 i) -> int16DuckValue i+        (DuckDBTypeInteger, FieldInt32 i) -> int32DuckValue i+        (DuckDBTypeBigInt, FieldInt64 i) -> int64DuckValue i+        (DuckDBTypeUTinyInt, FieldWord8 w) -> uint8DuckValue w+        (DuckDBTypeUSmallInt, FieldWord16 w) -> uint16DuckValue w+        (DuckDBTypeUInteger, FieldWord32 w) -> uint32DuckValue w+        (DuckDBTypeUBigInt, FieldWord64 w) -> uint64DuckValue w+        (DuckDBTypeFloat, FieldFloat f) -> floatDuckValue f+        (DuckDBTypeDouble, FieldDouble d) -> doubleDuckValue d+        (DuckDBTypeVarchar, FieldText t) -> textDuckValue t+        (DuckDBTypeBlob, FieldBlob b) -> blobDuckValue b+        (DuckDBTypeUUID, FieldUUID u) -> uuidDuckValue u+        (DuckDBTypeBit, FieldBit bits) -> bitDuckValue bits+        (DuckDBTypeDate, FieldDate d) -> dayDuckValue d+        (DuckDBTypeTime, FieldTime t) -> timeOfDayDuckValue t+        (DuckDBTypeTimeTz, FieldTimeTZ tz) -> timeWithZoneDuckValue tz+        (DuckDBTypeTimestamp, FieldTimestamp ts) -> localTimeDuckValue ts+        (DuckDBTypeTimestampTz, FieldTimestampTZ ts) -> utcTimeDuckValue ts+        (DuckDBTypeInterval, FieldInterval iv) -> intervalDuckValue iv+        (DuckDBTypeHugeInt, FieldHugeInt i) -> hugeIntDuckValue i+        (DuckDBTypeUHugeInt, FieldUHugeInt i) -> uhugeIntDuckValue i+        (DuckDBTypeBigNum, FieldBigNum big) -> bigNumDuckValue big+        (DuckDBTypeSQLNull, _) -> nullDuckValue+        _ ->+            case value of+                FieldNull -> nullDuckValue+                other ->+                    throwIO+                        ( userError+                            ( "duckdb-simple: unsupported scalar conversion for "+                                <> show dtype+                                <> " from "+                                <> show other+                            )+                        )++enumDuckValue :: Array Int Text -> Word32 -> IO DuckDBValue+enumDuckValue dict idx = do+    enumLogical <- logicalTypeFromRep (LogicalTypeEnum dict)+    result <- c_duckdb_create_enum_value enumLogical (fromIntegral idx)+    destroyLogicalType enumLogical+    pure result++hugeIntDuckValue :: Integer -> IO DuckDBValue+hugeIntDuckValue value =+    integerToHugeInt value >>= \huge ->+        alloca \ptr -> do+            poke ptr huge+            c_duckdb_create_hugeint ptr++uhugeIntDuckValue :: Integer -> IO DuckDBValue+uhugeIntDuckValue value =+    integerToUHugeInt value >>= \uhu ->+        alloca \ptr -> do+            poke ptr uhu+            c_duckdb_create_uhugeint ptr++decimalDuckValue :: DecimalValue -> IO DuckDBValue+decimalDuckValue DecimalValue{decimalWidth, decimalScale, decimalInteger} = do+    huge <- integerToHugeInt decimalInteger+    alloca \ptr -> do+        poke+            ptr+            DuckDBDecimal+                { duckDBDecimalWidth = decimalWidth+                , duckDBDecimalScale = decimalScale+                , duckDBDecimalValue = huge+                }+        c_duckdb_create_decimal ptr++intervalDuckValue :: IntervalValue -> IO DuckDBValue+intervalDuckValue IntervalValue{intervalMonths, intervalDays, intervalMicros} =+    alloca \ptr -> do+        poke ptr (DuckDBInterval intervalMonths intervalDays intervalMicros)+        c_duckdb_create_interval ptr++timeWithZoneDuckValue :: TimeWithZone -> IO DuckDBValue+timeWithZoneDuckValue TimeWithZone{timeWithZoneTime, timeWithZoneZone} = do+    let totalMicros = diffTimeToPicoseconds (timeOfDayToTime timeWithZoneTime) `div` 1000000+        offsetSeconds = timeZoneMinutes timeWithZoneZone * 60+    tzValue <- c_duckdb_create_time_tz (fromIntegral totalMicros) (fromIntegral offsetSeconds)+    c_duckdb_create_time_tz_value tzValue++integerToHugeInt :: Integer -> IO DuckDBHugeInt+integerToHugeInt value = do+    let minVal = negate (1 `shiftL` 127)+        maxVal = (1 `shiftL` 127) - 1+    when (value < minVal || value > maxVal) $+        throwIO (userError "duckdb-simple: HUGEINT value out of range")+    let lowerMask = (1 `shiftL` 64) - 1+        lower = fromIntegral (value .&. lowerMask)+        upper = fromIntegral (value `shiftR` 64)+    pure DuckDBHugeInt{duckDBHugeIntLower = lower, duckDBHugeIntUpper = upper}++integerToUHugeInt :: Integer -> IO DuckDBUHugeInt+integerToUHugeInt value = do+    let minVal = 0+        maxVal = (1 `shiftL` 128) - 1+    when (value < minVal || value > maxVal) $+        throwIO (userError "duckdb-simple: UHUGEINT value out of range")+    let lowerMask = (1 `shiftL` 64) - 1+        lower = fromIntegral (value .&. lowerMask)+        upper = fromIntegral (value `shiftR` 64)+    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+typeMismatch expected actual =+    throwIO+        ( userError+            ( "duckdb-simple: cannot encode "+                <> show actual+                <> " as "+                <> expected+            )+        )++createElementLogicalType :: forall a. (DuckDBColumnType a) => Proxy a -> IO DuckDBLogicalType+createElementLogicalType proxy =+    let typeName = duckdbColumnType proxy+     in case duckDBTypeFromName typeName of+            Just dtype -> c_duckdb_create_logical_type dtype+            Nothing ->+                throwIO+                    ( SQLError+                        { sqlErrorMessage =+                            Text.concat+                                [ "duckdb-simple: unsupported array element type "+                                , typeName+                                ]+                        , sqlErrorType = Nothing+                        , sqlErrorQuery = Nothing+                        }+                    )++duckDBTypeFromName :: Text -> Maybe DuckDBType+duckDBTypeFromName name =+    case name of+        "BOOLEAN" -> Just DuckDBTypeBoolean+        "TINYINT" -> Just DuckDBTypeTinyInt+        "SMALLINT" -> Just DuckDBTypeSmallInt+        "INTEGER" -> Just DuckDBTypeInteger+        "BIGINT" -> Just DuckDBTypeBigInt+        "UTINYINT" -> Just DuckDBTypeUTinyInt+        "USMALLINT" -> Just DuckDBTypeUSmallInt+        "UINTEGER" -> Just DuckDBTypeUInteger+        "UBIGINT" -> Just DuckDBTypeUBigInt+        "FLOAT" -> Just DuckDBTypeFloat+        "DOUBLE" -> Just DuckDBTypeDouble+        "DATE" -> Just DuckDBTypeDate+        "TIME" -> Just DuckDBTypeTime+        "TIMESTAMP" -> Just DuckDBTypeTimestamp+        "TIMESTAMPTZ" -> Just DuckDBTypeTimestampTz+        "TEXT" -> Just DuckDBTypeVarchar+        "BLOB" -> Just DuckDBTypeBlob+        "UUID" -> Just DuckDBTypeUUID+        "BIT" -> Just DuckDBTypeBit+        "BIGNUM" -> Just DuckDBTypeBigNum+        -- treat NULL as SQLNULL to provide element type for Maybe values without data+        "NULL" -> Just DuckDBTypeSQLNull+        _ -> Nothing++destroyLogicalType :: DuckDBLogicalType -> IO ()+destroyLogicalType logical =+    alloca $ \ptr -> do+        poke ptr logical+        c_duckdb_destroy_logical_type ptr++instance ToDuckValue Null where+    toDuckValue _ = nullDuckValue++instance ToDuckValue Bool where+    toDuckValue = boolDuckValue++instance ToDuckValue Int where+    toDuckValue = int64DuckValue . fromIntegral++instance ToDuckValue Int8 where+    toDuckValue = int8DuckValue++instance ToDuckValue Int16 where+    toDuckValue = int16DuckValue++instance ToDuckValue Int32 where+    toDuckValue = int32DuckValue++instance ToDuckValue Int64 where+    toDuckValue = int64DuckValue++instance ToDuckValue BigNum where+    toDuckValue = bigNumDuckValue++instance ToDuckValue UUID.UUID where+    toDuckValue = uuidDuckValue++instance ToDuckValue Integer where+    toDuckValue = bigNumDuckValue . BigNum++instance ToDuckValue Natural where+    toDuckValue = bigNumDuckValue . BigNum . toInteger++instance ToDuckValue Word where+    toDuckValue = uint64DuckValue . fromIntegral++instance ToDuckValue Word16 where+    toDuckValue = uint16DuckValue++instance ToDuckValue Word32 where+    toDuckValue = uint32DuckValue++instance ToDuckValue Word64 where+    toDuckValue = uint64DuckValue++instance ToDuckValue Word8 where+    toDuckValue = uint8DuckValue++instance ToDuckValue Double where+    toDuckValue = doubleDuckValue++instance ToDuckValue Float where+    toDuckValue = floatDuckValue++instance ToDuckValue Text where+    toDuckValue = textDuckValue++instance ToDuckValue String where+    toDuckValue = stringDuckValue++instance ToDuckValue BS.ByteString where+    toDuckValue = blobDuckValue++instance ToDuckValue BitString where+    toDuckValue = bitDuckValue++instance ToDuckValue Day where+    toDuckValue = dayDuckValue++instance ToDuckValue TimeOfDay where+    toDuckValue = timeOfDayDuckValue++instance ToDuckValue LocalTime where+    toDuckValue = localTimeDuckValue++instance ToDuckValue UTCTime where+    toDuckValue = utcTimeDuckValue++instance ToDuckValue (StructValue FieldValue) where+    toDuckValue = structValueDuckValue++instance ToDuckValue (UnionValue FieldValue) where+    toDuckValue = unionValueDuckValue++instance (ToDuckValue a) => ToDuckValue (Maybe a) where+    toDuckValue Nothing = nullDuckValue+    toDuckValue (Just value) = toDuckValue value  encodeDay :: Day -> IO DuckDBDate encodeDay day =

@@ -1,19 +1,21 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}+{-# LANGUAGE LambdaCase #-}  -- | Tasty-based test suite for duckdb-simple. module Main (main) where  import Control.Applicative ((<|>)) import Control.Exception (ErrorCall, Exception, SomeException, displayException, fromException, try)-import Control.Monad (replicateM_)+import Control.Monad (forM_, replicateM_) import qualified Data.ByteString as BS+import Data.Array (Array, elems, listArray) import Data.IORef (atomicModifyIORef', newIORef) import Data.Int (Int16, Int32, Int64, Int8) import Data.List (sortOn)@@ -34,19 +36,31 @@ import Data.Word (Word16, Word32, Word64, Word8) import Data.Ratio ((%)) import Database.DuckDB.Simple-import Database.DuckDB.Simple.FromField (-    BigNum (..),-    BitString (..),-    bsFromBool,-    DecimalValue (..),-    Field (..),-    FieldValue (..),-    IntervalValue (..),-    TimeWithZone (..),-    fromBigNumBytes,-    returnError,-    toBigNumBytes,- )+import Database.DuckDB.Simple.FromField+    ( BigNum (..)+    , BitString (..)+    , bsFromBool+    , DecimalValue (..)+    , Field (..)+    , FieldValue (..)+    , IntervalValue (..)+    , TimeWithZone (..)+    , fromBigNumBytes+    , returnError+    , toBigNumBytes+    )+import Database.DuckDB.Simple.LogicalRep+    ( StructField (..)+    , StructValue (..)+    , UnionMemberType (..)+    , UnionValue (..)+    )+import Database.DuckDB.Simple.Generic+    ( genericFromFieldValue+    , genericToFieldValue+    , genericToStructValue+    , ViaDuckDB (..)+    ) import Database.DuckDB.Simple.Ok (Ok (..)) import GHC.Generics (Generic) import Numeric.Natural (Natural)@@ -67,6 +81,60 @@ data WithRemaining = WithRemaining Int Int     deriving (Eq, Show) +data GenericRecord = GenericRecord+    { grId :: Int+    , grName :: Text.Text+    }+    deriving stock (Eq, Show, Generic)++data GenericSum+    = SumInt Int+    | SumBool Bool+    | SumPair Int Text.Text+    deriving stock (Eq, Show, Generic)++data GenericEnum+    = EnumRed+    | EnumBlue+    deriving stock (Eq, Show, Generic)++data ViaUser = ViaUser+    { vuId :: Int64+    , vuName :: Text.Text+    }+    deriving stock (Eq, Show, Generic)+    deriving (DuckDBColumnType, ToField, FromField) via (ViaDuckDB ViaUser)++data ViaShape+    = ViaCircle Double+    | ViaSquare Double+    deriving stock (Eq, Show, Generic)+    deriving (DuckDBColumnType, ToField, FromField) via (ViaDuckDB ViaShape)++-- Edge case test types+data TwoFieldStruct = TwoFieldStruct Int Text.Text+    deriving stock (Eq, Show, Generic)++data LargeSumType+    = LargeC1 Int+    | LargeC2 Int+    | LargeC3 Int+    | LargeC4 Int+    | LargeC5 Int+    deriving stock (Eq, Show, Generic)+    deriving (DuckDBColumnType, ToField, FromField) via (ViaDuckDB LargeSumType)++data EmptyStruct = EmptyStruct+    deriving stock (Eq, Show, Generic)+    deriving (DuckDBColumnType, ToField, FromField) via (ViaDuckDB EmptyStruct)++data OptionalFields = OptionalFields+    { ofInt :: Maybe Int+    , ofText :: Maybe Text.Text+    }+    deriving stock (Eq, Show, Generic)+    deriving (DuckDBColumnType, ToField, FromField) via (ViaDuckDB OptionalFields)+ instance FromRow WithRemaining where     fromRow = do         firstVal <- field@@ -375,7 +443,7 @@                         result <- try (query_ conn sql) :: IO (Either SomeException [Only FieldValue])                         runExpectation castLabel castExpectation result                         maybe (pure ()) assertFailure castExpectFailureReason-         in maybe base (\reason -> expectFailBecause reason base) castExpectFailureReason+         in maybe base (`expectFailBecause` base) castExpectFailureReason  runExpectation :: String -> DuckDBExpectation -> Either SomeException [Only FieldValue] -> Assertion runExpectation label expectation outcome =@@ -436,12 +504,11 @@     , successCase "BIGNUM" (quoted bigNumLiteralText) "BIGNUM" (ExpectEquals (FieldBigNum (BigNum bigNumLiteral)))     , successCase "UUID" (quoted $ UUID.toText uuid) "UUID" (ExpectEquals (FieldUUID uuid))     , successCase "BIT" (quoted $ Text.pack $ show bits) "BIT" (ExpectEquals (FieldBit bits))+    , successCase "ARRAY" (quoted "[1,2,3]") "INTEGER[3]" (ExpectEquals (FieldArray arrayElements))      -- This one is broken upstream, instead of a DuckDBTypeTimeNs, we get a DuckDBType 0-     , failCaseWith "TIME_NS" (quoted "03:04:05.123456789") "TIME_NS" "TIME_NS decoding unsupported" (expectErrorCallContaining "unsupported DuckDB type")-      -- not implemented yet-    , failCaseWith "STRUCT" (quoted "{\"a\":1,\"b\":2}") "STRUCT(a INTEGER, b INTEGER)" "STRUCT decoding unsupported" (expectErrorCallContaining "STRUCT columns are not supported")-    , failCaseWith "ARRAY" (quoted "[1,2,3]") "INTEGER[3]" "ARRAY decoding unsupported" (expectErrorCallContaining "unsupported DuckDB type")-    , failCaseWith "UNION" (quoted "1") "UNION(\"value\" INTEGER)" "UNION casts unsupported" (expectSQLErrorContaining "UNION")+    , failCaseWith "TIME_NS" (quoted "03:04:05.123456789") "TIME_NS" "TIME_NS decoding unsupported" (expectErrorCallContaining "INVALID")+    , successDirect "STRUCT" "{'a': 1, 'b': 2}" (expectStruct structFields)+    , successDirect "UNION" "CAST(union_value(a := 42) AS UNION(a INTEGER, b VARCHAR))" (expectUnion 0 (Text.pack "a") (FieldInt32 42))     -- These can never surface from a query, only internally.     , failCaseOK "ANY" (quoted "1") "ANY" (expectSQLErrorContaining "ANY")     , failCaseOK "STRING_LITERAL" (quoted literalText) "STRING_LITERAL" (expectSQLErrorContaining "STRING_LITERAL")@@ -484,15 +551,45 @@             , castExpectFailureReason = Nothing             }     expectMapEntries expectedPairs =-        ExpectSatisfies $ \fieldValue ->-            case fieldValue of-                FieldMap actualPairs ->-                    let normalize pairs = sortOn (mapKey . fst) pairs-                        mapKey (FieldText txt) = txt-                        mapKey other = Text.pack (show other)-                     in assertEqual "map entries" (normalize expectedPairs) (normalize actualPairs)+        ExpectSatisfies $+           \case+             FieldMap actualPairs ->+                 let normalize = sortOn (mapKey . fst)+                     mapKey (FieldText txt) = txt+                     mapKey other = Text.pack (show other)+                  in assertEqual "map entries" (normalize expectedPairs) (normalize actualPairs)+             other ->+                 assertFailure ("expected FieldMap, but saw " <> show other)+    structFields =+        [ StructField{structFieldName = Text.pack "a", structFieldValue = FieldInt32 1}+        , StructField{structFieldName = Text.pack "b", structFieldValue = FieldInt32 2}+        ]+    expectStruct expectedFields =+        ExpectSatisfies $+            \case+                FieldStruct StructValue{structValueFields, structValueTypes, structValueIndex} -> do+                    let actualFields = elems structValueFields+                        actualTypes = elems structValueTypes+                        expectedIndex = Map.fromList (zip (map structFieldName expectedFields) [0 ..])+                        typeNames = map structFieldName actualTypes+                    assertEqual "struct field names" (map structFieldName expectedFields) (map structFieldName actualFields)+                    assertEqual "struct field values" (map structFieldValue expectedFields) (map structFieldValue actualFields)+                    assertEqual "struct type field names" (map structFieldName expectedFields) typeNames+                    assertEqual "struct index map" expectedIndex structValueIndex                 other ->-                    assertFailure ("expected FieldMap, but saw " <> show other)+                    assertFailure ("expected FieldStruct, but saw " <> show other)+    expectUnion expectedIndex expectedLabel expectedPayload =+        ExpectSatisfies $+            \case+                FieldUnion UnionValue{unionValueIndex, unionValueLabel, unionValuePayload, unionValueMembers} -> do+                    assertEqual "union tag index" expectedIndex unionValueIndex+                    assertEqual "union tag label" expectedLabel unionValueLabel+                    assertEqual "union payload" expectedPayload unionValuePayload+                    let actualMembers = elems unionValueMembers+                        expectedMembers = [Text.pack "a", Text.pack "b"]+                    assertEqual "union member names" expectedMembers (map unionMemberName actualMembers)+                other ->+                    assertFailure ("expected FieldUnion, but saw " <> show other)     expectSQLErrorContaining :: Text.Text -> DuckDBExpectation     expectSQLErrorContaining needle =         ExpectException $ \err ->@@ -558,6 +655,8 @@         DecimalValue{decimalWidth = 18, decimalScale = 4, decimalInteger = 123456789}     listElements =         [FieldInt32 1, FieldInt32 2, FieldInt32 3]+    arrayElements =+        listArray (0, 2) listElements     mapPairs =         [ (FieldText (Text.pack "a"), FieldInt32 1)         , (FieldText (Text.pack "b"), FieldInt32 2)@@ -621,6 +720,18 @@                 assertEqual "Word64 round-trip" w64 r64                 [Only (asWord :: Word)] <- query_ conn "SELECT u64 FROM unsigneds"                 assertEqual "Word from UBIGINT" (fromIntegral w64) asWord+        , testCase "round-trips fixed-length arrays" $+            withConnection ":memory:" \conn -> do+                _ <- execute_ conn "CREATE TABLE arrays (vals INTEGER[3])"+                let inputs =+                        [ listArray (0, 2) [1, 2, 3]+                        , listArray (0, 2) [4, 5, 6]+                        ]+                _ <- executeMany conn "INSERT INTO arrays VALUES (?)" (Only <$> inputs)+                rows <- query_ conn "SELECT vals FROM arrays ORDER BY rowid" :: IO [Only (Array Int Int)]+                let expected =+                        fmap Only inputs+                assertEqual "array round-trip" expected rows         , testCase "decodes huge integers as Integer" $             withConnection ":memory:" \conn -> do                 let hugeValue = 170141183460469231731687303715884105727 :: Integer@@ -783,6 +894,146 @@                 _ <- executeMany conn "INSERT INTO bits VALUES (?)" (fmap Only bitValues)                 rows <- query_ conn "SELECT bit FROM bits ORDER BY rowid" :: IO [Only BitString]                 assertEqual "bit round-trip" (fmap Only bitValues) rows+        , testCase "round-trips struct and union parameters" $+            withConnection ":memory:" \conn -> do+                _ <- execute_ conn "CREATE TABLE struct_union (s STRUCT(a INT, b INT), u UNION(a INT, b VARCHAR))"+                [(structVal, unionVal)] <-+                    query_ conn "SELECT {'a': 1, 'b': 2}, CAST(union_value(a := 42) AS UNION(a INTEGER, b VARCHAR))" :: IO [(StructValue FieldValue, UnionValue FieldValue)]+                _ <- execute conn "INSERT INTO struct_union VALUES (?, ?)" (structVal, unionVal)+                rows <- query_ conn "SELECT s, u FROM struct_union" :: IO [(StructValue FieldValue, UnionValue FieldValue)]+                assertEqual "struct/union round-trip" [(structVal, unionVal)] rows+        , testCase "generic struct into database" $+            withConnection ":memory:" \conn -> do+                _ <- execute_ conn "CREATE TABLE generic_struct (payload STRUCT(grId INT, grName TEXT))"+                let records = [GenericRecord 1 (Text.pack "alpha"), GenericRecord 2 (Text.pack "beta")]+                    structParams = traverse genericToStructValue records+                case structParams of+                    Nothing -> assertFailure "expected struct encoding"+                    Just structs -> do+                        _ <- executeMany conn "INSERT INTO generic_struct VALUES (?)" (map Only structs)+                        rows <- query_ conn "SELECT payload FROM generic_struct ORDER BY payload.grId" :: IO [Only (StructValue FieldValue)]+                        let unwrap (Only s) = s+                            roundTripped = traverse (genericFromFieldValue . FieldStruct . unwrap) rows+                        roundTripped @?= Right records+        , testCase "generic struct encode/decode" $ do+            let rec = GenericRecord 42 (Text.pack "duck")+            case genericToStructValue rec of+                Just structVal -> do+                    map structFieldName (elems (structValueFields structVal)) @?= [Text.pack "grId", Text.pack "grName"]+                    map structFieldValue (elems (structValueFields structVal)) @?= [FieldInt64 42, FieldText (Text.pack "duck")]+                    genericFromFieldValue (FieldStruct structVal) @?= Right rec+                Nothing -> assertFailure "expected struct encoding"+        , testCase "generic union encode/decode" $ do+            let sumVal = SumBool True+            case genericToFieldValue sumVal of+                FieldUnion uv -> do+                    map unionMemberName (elems (unionValueMembers uv)) @?=+                        [ Text.pack "SumInt"+                        , Text.pack "SumBool"+                        , Text.pack "SumPair"+                        ]+                    unionValueLabel uv @?= Text.pack "SumBool"+                    genericFromFieldValue (FieldUnion uv) @?= Right sumVal+                other -> assertFailure ("expected FieldUnion, got " <> show other)+        , testCase "generic union complex constructor" $ do+            let sumVal = SumPair 7 (Text.pack "duck")+            case genericToFieldValue sumVal of+                FieldUnion uv -> do+                    unionValueLabel uv @?= Text.pack "SumPair"+                    case unionValuePayload uv of+                        FieldStruct StructValue{structValueFields} -> do+                            map structFieldName (elems structValueFields) @?= [Text.pack "field1", Text.pack "field2"]+                            map structFieldValue (elems structValueFields) @?=+                                [FieldInt64 7, FieldText (Text.pack "duck")]+                        other -> assertFailure ("expected struct payload, got " <> show other)+                    genericFromFieldValue (FieldUnion uv) @?= Right sumVal+                other -> assertFailure ("expected FieldUnion, got " <> show other)+        , testCase "deriving via generic struct round-trip" $+            withConnection ":memory:" \conn -> do+                _ <- execute_ conn "CREATE TABLE via_users (payload STRUCT(vuId BIGINT, vuName TEXT))"+                let users = [ViaUser 10 (Text.pack "alice"), ViaUser 11 (Text.pack "bob")]+                _ <- executeMany conn "INSERT INTO via_users VALUES (?)" (map Only users)+                rows <- query_ conn "SELECT payload FROM via_users ORDER BY payload.vuId" :: IO [Only ViaUser]+                rows @?= map Only users+        , testCase "deriving via generic union round-trip" $+            withConnection ":memory:" \conn -> do+                _ <- execute_ conn "CREATE TABLE via_shapes (shape UNION(ViaCircle STRUCT(field1 DOUBLE), ViaSquare STRUCT(field1 DOUBLE)))"+                let shapes = [ViaCircle 1.5, ViaSquare 3.0]+                _ <- executeMany conn "INSERT INTO via_shapes VALUES (?)" (map Only shapes)+                rows <- query_ conn "SELECT shape FROM via_shapes ORDER BY rowid" :: IO [Only ViaShape]+                rows @?= map Only shapes+        , testCase "generic enum null payload" $ do+            case genericToFieldValue EnumRed of+                FieldUnion uv -> do+                    unionValuePayload uv @?= FieldNull+                    genericFromFieldValue (FieldUnion uv) @?= Right EnumRed+                other -> assertFailure ("expected FieldUnion, got " <> show other)+        -- Edge case tests+        , testCase "struct with multiple basic fields" $ do+            -- Test a struct with multiple fields+            let twoField = TwoFieldStruct 42 (Text.pack "text")+            case genericToFieldValue twoField of+                FieldStruct sv -> do+                    genericFromFieldValue (FieldStruct sv) @?= Right twoField+                other -> assertFailure ("expected FieldStruct for TwoFieldStruct, got " <> show other)+        , testCase "large sum type with many constructors" $ do+            let constructors = [LargeC1 1, LargeC2 2, LargeC3 3, LargeC4 4, LargeC5 5]+            forM_ constructors $ \val -> do+                case genericToFieldValue val of+                    FieldUnion uv -> do+                        genericFromFieldValue (FieldUnion uv) @?= Right val+                    other -> assertFailure ("expected FieldUnion, got " <> show other)+        , testCase "empty struct encodes as null" $ do+            case genericToFieldValue EmptyStruct of+                FieldNull -> pure ()+                other -> assertFailure ("expected FieldNull for empty struct, got " <> show other)+        , testCase "struct with Maybe fields" $ do+            let withJust = OptionalFields (Just 42) (Just (Text.pack "text"))+                withNothing = OptionalFields Nothing Nothing+            case (genericToFieldValue withJust, genericToFieldValue withNothing) of+                (FieldStruct sv1, FieldStruct sv2) -> do+                    genericFromFieldValue (FieldStruct sv1) @?= Right withJust+                    genericFromFieldValue (FieldStruct sv2) @?= Right withNothing+                (other1, other2) -> assertFailure ("expected FieldStruct, got " <> show (other1, other2))+        -- Error case tests+        , testCase "decode wrong field type fails" $ do+            let wrongType = FieldInt32 42  -- Trying to decode as GenericRecord+            case genericFromFieldValue wrongType :: Either String GenericRecord of+                Left err -> assertBool "error mentions STRUCT" (Text.pack "STRUCT" `Text.isInfixOf` Text.pack err)+                Right _ -> assertFailure "expected decode error for wrong type"+        , testCase "decode union as struct fails" $ do+            case genericToFieldValue (SumInt 42) of+                FieldUnion uv -> do+                    case genericFromFieldValue (FieldUnion uv) :: Either String GenericRecord of+                        Left err -> assertBool "error mentions product type" (Text.pack "product type" `Text.isInfixOf` Text.pack err)+                        Right _ -> assertFailure "expected decode error"+                other -> assertFailure ("expected FieldUnion, got " <> show other)+        , testCase "decode struct as union fails" $ do+            case genericToFieldValue (GenericRecord 1 (Text.pack "test")) of+                FieldStruct sv -> do+                    case genericFromFieldValue (FieldStruct sv) :: Either String GenericSum of+                        Left err -> assertBool "error mentions sum type" (Text.pack "sum type" `Text.isInfixOf` Text.pack err)+                        Right _ -> assertFailure "expected decode error"+                other -> assertFailure ("expected FieldStruct, got " <> show other)+        , testCase "decode struct with wrong field count fails" $+            withConnection ":memory:" \conn -> do+                -- Get a real struct with 3 fields from the database+                _ <- execute_ conn "CREATE TABLE three_field (s STRUCT(a INT, b TEXT, c INT))"+                [(Only threeField)] <- query_ conn "SELECT {'a': 1, 'b': 'test', 'c': 99}" :: IO [Only (StructValue FieldValue)]+                -- Try to decode it as GenericRecord which only has 2 fields+                case genericFromFieldValue (FieldStruct threeField) :: Either String GenericRecord of+                    Left err -> assertBool "error mentions extra fields" (Text.pack "extra" `Text.isInfixOf` Text.pack err)+                    Right _ -> assertFailure "expected decode error for extra fields"+        , testCase "decode union with wrong tag fails" $+            withConnection ":memory:" \conn -> do+                -- Get a real union from the database+                [(Only unionVal)] <-+                    query_ conn "SELECT CAST(union_value(x := 42) AS UNION(x INT, y VARCHAR))" :: IO [Only (UnionValue FieldValue)]+                -- Manually create a modified version with an out-of-range tag+                let wrongTag = unionVal{unionValueIndex = 99, unionValueLabel = Text.pack "Invalid"}+                case genericFromFieldValue (FieldUnion wrongTag) :: Either String GenericSum of+                    Left err -> assertBool "error mentions tag or index" (Text.pack "tag" `Text.isInfixOf` Text.pack err || Text.pack "99" `Text.isInfixOf` Text.pack err)+                    Right _ -> assertFailure "expected decode error for wrong tag"         ]  streamingTests :: TestTree