{-# 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 (..),
    GToField (),
    GFromField (),

    -- * 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 qualified Data.ByteString as BS
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 (UTCTime)
import Data.Time.Calendar (Day)
import Data.Time.LocalTime (LocalTime, TimeOfDay)
import Data.Typeable (Typeable)
import qualified Data.UUID as UUID
import Data.Word (Word16, Word32, Word64, Word8)
import GHC.Generics
import Numeric.Natural (Natural)

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 FieldValue
fv =
        case FieldParser a
forall a. FromField a => FieldParser a
fromField Field{fieldName :: Text
fieldName = Text
Text.empty, fieldIndex :: Int
fieldIndex = Int
0, fieldValue :: FieldValue
fieldValue = FieldValue
fv} of
            Ok a
x -> a -> Either String a
forall a b. b -> Either a b
Right a
x
            Errors [SomeException]
errs -> String -> Either String a
forall a b. a -> Either a b
Left ([String] -> String
unlines ((SomeException -> String) -> [SomeException] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SomeException -> String
forall e. Exception e => e -> String
displayException [SomeException]
errs))

instance DuckValue Bool where
    duckToField :: Bool -> FieldValue
duckToField = Bool -> FieldValue
FieldBool
    duckLogicalType :: Proxy Bool -> LogicalTypeRep
duckLogicalType Proxy Bool
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeBoolean

instance DuckValue Int where
    duckToField :: Int -> FieldValue
duckToField = Int64 -> FieldValue
FieldInt64 (Int64 -> FieldValue) -> (Int -> Int64) -> Int -> FieldValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    duckLogicalType :: Proxy Int -> LogicalTypeRep
duckLogicalType Proxy Int
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeBigInt

instance DuckValue Int8 where
    duckToField :: Int8 -> FieldValue
duckToField = Int8 -> FieldValue
FieldInt8
    duckLogicalType :: Proxy Int8 -> LogicalTypeRep
duckLogicalType Proxy Int8
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeTinyInt

instance DuckValue Int16 where
    duckToField :: Int16 -> FieldValue
duckToField = Int16 -> FieldValue
FieldInt16
    duckLogicalType :: Proxy Int16 -> LogicalTypeRep
duckLogicalType Proxy Int16
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeSmallInt

instance DuckValue Int32 where
    duckToField :: Int32 -> FieldValue
duckToField = Int32 -> FieldValue
FieldInt32
    duckLogicalType :: Proxy Int32 -> LogicalTypeRep
duckLogicalType Proxy Int32
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeInteger

instance DuckValue Int64 where
    duckToField :: Int64 -> FieldValue
duckToField = Int64 -> FieldValue
FieldInt64
    duckLogicalType :: Proxy Int64 -> LogicalTypeRep
duckLogicalType Proxy Int64
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeBigInt

instance DuckValue Integer where
    duckToField :: Integer -> FieldValue
duckToField = Integer -> FieldValue
FieldHugeInt
    duckLogicalType :: Proxy Integer -> LogicalTypeRep
duckLogicalType Proxy Integer
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeHugeInt

instance DuckValue Natural where
    duckToField :: Natural -> FieldValue
duckToField = Integer -> FieldValue
FieldUHugeInt (Integer -> FieldValue)
-> (Natural -> Integer) -> Natural -> FieldValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Integer
forall a. Integral a => a -> Integer
toInteger
    duckLogicalType :: Proxy Natural -> LogicalTypeRep
duckLogicalType Proxy Natural
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeUHugeInt

instance DuckValue Word where
    duckToField :: Word -> FieldValue
duckToField = Word64 -> FieldValue
FieldWord64 (Word64 -> FieldValue) -> (Word -> Word64) -> Word -> FieldValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    duckLogicalType :: Proxy Word -> LogicalTypeRep
duckLogicalType Proxy Word
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeUBigInt

instance DuckValue Word8 where
    duckToField :: Word8 -> FieldValue
duckToField = Word8 -> FieldValue
FieldWord8
    duckLogicalType :: Proxy Word8 -> LogicalTypeRep
duckLogicalType Proxy Word8
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeUTinyInt

instance DuckValue Word16 where
    duckToField :: Word16 -> FieldValue
duckToField = Word16 -> FieldValue
FieldWord16
    duckLogicalType :: Proxy Word16 -> LogicalTypeRep
duckLogicalType Proxy Word16
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeUSmallInt

instance DuckValue Word32 where
    duckToField :: Word32 -> FieldValue
duckToField = Word32 -> FieldValue
FieldWord32
    duckLogicalType :: Proxy Word32 -> LogicalTypeRep
duckLogicalType Proxy Word32
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeUInteger

instance DuckValue Word64 where
    duckToField :: Word64 -> FieldValue
duckToField = Word64 -> FieldValue
FieldWord64
    duckLogicalType :: Proxy Word64 -> LogicalTypeRep
duckLogicalType Proxy Word64
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeUBigInt

instance DuckValue Float where
    duckToField :: Float -> FieldValue
duckToField = Float -> FieldValue
FieldFloat
    duckLogicalType :: Proxy Float -> LogicalTypeRep
duckLogicalType Proxy Float
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeFloat

instance DuckValue Double where
    duckToField :: Double -> FieldValue
duckToField = Double -> FieldValue
FieldDouble
    duckLogicalType :: Proxy Double -> LogicalTypeRep
duckLogicalType Proxy Double
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeDouble

instance DuckValue Text where
    duckToField :: Text -> FieldValue
duckToField = Text -> FieldValue
FieldText
    duckLogicalType :: Proxy Text -> LogicalTypeRep
duckLogicalType Proxy Text
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeVarchar

instance DuckValue String where
    duckToField :: String -> FieldValue
duckToField = Text -> FieldValue
FieldText (Text -> FieldValue) -> (String -> Text) -> String -> FieldValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack
    duckLogicalType :: Proxy String -> LogicalTypeRep
duckLogicalType Proxy String
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeVarchar
    duckFromField :: FieldValue -> Either String String
duckFromField FieldValue
fv = Text -> String
Text.unpack (Text -> String) -> Either String Text -> Either String String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldValue -> Either String Text
forall a. DuckValue a => FieldValue -> Either String a
duckFromField FieldValue
fv

instance DuckValue BS.ByteString where
    duckToField :: ByteString -> FieldValue
duckToField = ByteString -> FieldValue
FieldBlob
    duckLogicalType :: Proxy ByteString -> LogicalTypeRep
duckLogicalType Proxy ByteString
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeBlob

instance DuckValue Day where
    duckToField :: Day -> FieldValue
duckToField = Day -> FieldValue
FieldDate
    duckLogicalType :: Proxy Day -> LogicalTypeRep
duckLogicalType Proxy Day
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeDate

instance DuckValue TimeOfDay where
    duckToField :: TimeOfDay -> FieldValue
duckToField = TimeOfDay -> FieldValue
FieldTime
    duckLogicalType :: Proxy TimeOfDay -> LogicalTypeRep
duckLogicalType Proxy TimeOfDay
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeTime

instance DuckValue LocalTime where
    duckToField :: LocalTime -> FieldValue
duckToField = LocalTime -> FieldValue
FieldTimestamp
    duckLogicalType :: Proxy LocalTime -> LogicalTypeRep
duckLogicalType Proxy LocalTime
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeTimestamp

instance DuckValue UTCTime where
    duckToField :: UTCTime -> FieldValue
duckToField = UTCTime -> FieldValue
FieldTimestampTZ
    duckLogicalType :: Proxy UTCTime -> LogicalTypeRep
duckLogicalType Proxy UTCTime
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeTimestampTz

instance DuckValue UUID.UUID where
    duckToField :: UUID -> FieldValue
duckToField = UUID -> FieldValue
FieldUUID
    duckLogicalType :: Proxy UUID -> LogicalTypeRep
duckLogicalType Proxy UUID
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeUUID

instance DuckValue IntervalValue where
    duckToField :: IntervalValue -> FieldValue
duckToField = IntervalValue -> FieldValue
FieldInterval
    duckLogicalType :: Proxy IntervalValue -> LogicalTypeRep
duckLogicalType Proxy IntervalValue
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeInterval

instance DuckValue TimeWithZone where
    duckToField :: TimeWithZone -> FieldValue
duckToField = TimeWithZone -> FieldValue
FieldTimeTZ
    duckLogicalType :: Proxy TimeWithZone -> LogicalTypeRep
duckLogicalType Proxy TimeWithZone
_ = DuckDBType -> LogicalTypeRep
LogicalTypeScalar DuckDBType
DuckDBTypeTimeTz

instance (DuckValue a) => DuckValue (Maybe a) where
    duckToField :: Maybe a -> FieldValue
duckToField (Just a
x) = a -> FieldValue
forall a. DuckValue a => a -> FieldValue
duckToField a
x
    duckToField Maybe a
Nothing = FieldValue
FieldNull
    duckLogicalType :: Proxy (Maybe a) -> LogicalTypeRep
duckLogicalType Proxy (Maybe a)
_ = Proxy a -> LogicalTypeRep
forall a. DuckValue a => Proxy a -> LogicalTypeRep
duckLogicalType (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    duckFromField :: FieldValue -> Either String (Maybe a)
duckFromField FieldValue
FieldNull = Maybe a -> Either String (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
    duckFromField FieldValue
other = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Either String a -> Either String (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldValue -> Either String a
forall a. DuckValue a => FieldValue -> Either String a
duckFromField FieldValue
other

-- | List values encode as DuckDB LIST (variable-length).
instance (DuckValue a) => DuckValue [a] where
    duckToField :: [a] -> FieldValue
duckToField [a]
xs = [FieldValue] -> FieldValue
FieldList ((a -> FieldValue) -> [a] -> [FieldValue]
forall a b. (a -> b) -> [a] -> [b]
map a -> FieldValue
forall a. DuckValue a => a -> FieldValue
duckToField [a]
xs)
    duckLogicalType :: Proxy [a] -> LogicalTypeRep
duckLogicalType Proxy [a]
_ = LogicalTypeRep -> LogicalTypeRep
LogicalTypeList (Proxy a -> LogicalTypeRep
forall a. DuckValue a => Proxy a -> LogicalTypeRep
duckLogicalType (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a))
    duckFromField :: FieldValue -> Either String [a]
duckFromField (FieldList [FieldValue]
fvs) = (FieldValue -> Either String a)
-> [FieldValue] -> Either String [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse FieldValue -> Either String a
forall a. DuckValue a => FieldValue -> Either String a
duckFromField [FieldValue]
fvs
    duckFromField FieldValue
other = String -> Either String [a]
forall a b. a -> Either a b
Left (String
"duckdb-simple: expected LIST, got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> FieldValue -> String
forall a. Show a => a -> String
show FieldValue
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 :: Array Int a -> FieldValue
duckToField Array Int a
arr =
        let values :: [a]
values = Array Int a -> [a]
forall i e. Array i e -> [e]
elems Array Int a
arr
            (Int
low, Int
high) = (Int
0, [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
values Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
         in Array Int FieldValue -> FieldValue
FieldArray ((Int, Int) -> [FieldValue] -> Array Int FieldValue
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
low, Int
high) ((a -> FieldValue) -> [a] -> [FieldValue]
forall a b. (a -> b) -> [a] -> [b]
map a -> FieldValue
forall a. DuckValue a => a -> FieldValue
duckToField [a]
values))
    duckLogicalType :: Proxy (Array Int a) -> LogicalTypeRep
duckLogicalType Proxy (Array Int a)
_ =
        -- 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.
        LogicalTypeRep -> Word64 -> LogicalTypeRep
LogicalTypeArray (Proxy a -> LogicalTypeRep
forall a. DuckValue a => Proxy a -> LogicalTypeRep
duckLogicalType (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) Word64
0
    duckFromField :: FieldValue -> Either String (Array Int a)
duckFromField (FieldArray Array Int FieldValue
arr) = do
        let values :: [FieldValue]
values = Array Int FieldValue -> [FieldValue]
forall i e. Array i e -> [e]
elems Array Int FieldValue
arr
        decoded <- (FieldValue -> Either String a)
-> [FieldValue] -> Either String [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse FieldValue -> Either String a
forall a. DuckValue a => FieldValue -> Either String a
duckFromField [FieldValue]
values
        let (low, high) = (0, length decoded - 1)
        pure (listArray (low, high) decoded)
    duckFromField FieldValue
other = String -> Either String (Array Int a)
forall a b. a -> Either a b
Left (String
"duckdb-simple: expected ARRAY, got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> FieldValue -> String
forall a. Show a => a -> String
show FieldValue
other)

-- | Map values encode as DuckDB MAP.
instance (Ord k, DuckValue k, DuckValue v) => DuckValue (Map.Map k v) where
    duckToField :: Map k v -> FieldValue
duckToField Map k v
m =
        let pairs :: [(k, v)]
pairs = Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.toList Map k v
m
         in [(FieldValue, FieldValue)] -> FieldValue
FieldMap [(k -> FieldValue
forall a. DuckValue a => a -> FieldValue
duckToField k
k, v -> FieldValue
forall a. DuckValue a => a -> FieldValue
duckToField v
v) | (k
k, v
v) <- [(k, v)]
pairs]
    duckLogicalType :: Proxy (Map k v) -> LogicalTypeRep
duckLogicalType Proxy (Map k v)
_ =
        LogicalTypeRep -> LogicalTypeRep -> LogicalTypeRep
LogicalTypeMap
            (Proxy k -> LogicalTypeRep
forall a. DuckValue a => Proxy a -> LogicalTypeRep
duckLogicalType (Proxy k
forall {k} (t :: k). Proxy t
Proxy :: Proxy k))
            (Proxy v -> LogicalTypeRep
forall a. DuckValue a => Proxy a -> LogicalTypeRep
duckLogicalType (Proxy v
forall {k} (t :: k). Proxy t
Proxy :: Proxy v))
    duckFromField :: FieldValue -> Either String (Map k v)
duckFromField (FieldMap [(FieldValue, FieldValue)]
pairs) = do
        decodedPairs <- ((FieldValue, FieldValue) -> Either String (k, v))
-> [(FieldValue, FieldValue)] -> Either String [(k, v)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (FieldValue, FieldValue) -> Either String (k, v)
forall {a} {b}.
(DuckValue a, DuckValue b) =>
(FieldValue, FieldValue) -> Either String (a, b)
decodePair [(FieldValue, FieldValue)]
pairs
        pure (Map.fromList decodedPairs)
      where
        decodePair :: (FieldValue, FieldValue) -> Either String (a, b)
decodePair (FieldValue
kfv, FieldValue
vfv) = do
            k <- FieldValue -> Either String a
forall a. DuckValue a => FieldValue -> Either String a
duckFromField FieldValue
kfv
            v <- duckFromField vfv
            pure (k, v)
    duckFromField FieldValue
other = String -> Either String (Map k v)
forall a b. a -> Either a b
Left (String
"duckdb-simple: expected MAP, got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> FieldValue -> String
forall a. Show a => a -> String
show FieldValue
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 :: Encoded -> FieldValue
encodedValue = \case
    EncodedStruct StructValue FieldValue
sv Array Int (StructField LogicalTypeRep)
_ -> StructValue FieldValue -> FieldValue
FieldStruct StructValue FieldValue
sv
    EncodedUnion UnionValue FieldValue
uv -> UnionValue FieldValue -> FieldValue
FieldUnion UnionValue FieldValue
uv
    Encoded
EncodedNull -> FieldValue
FieldNull

-- | Convert a Haskell value (using its generic representation) into a DuckDB @FieldValue@.
genericToFieldValue :: forall a. (Generic a, GToField (Rep a)) => a -> FieldValue
genericToFieldValue :: forall a. (Generic a, GToField (Rep a)) => a -> FieldValue
genericToFieldValue = Encoded -> FieldValue
encodedValue (Encoded -> FieldValue) -> (a -> Encoded) -> a -> FieldValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a (ZonkAny 3) -> Encoded
forall p. Rep a p -> Encoded
forall (f :: * -> *) p. GToField f => f p -> Encoded
gToField (Rep a (ZonkAny 3) -> Encoded)
-> (a -> Rep a (ZonkAny 3)) -> a -> Encoded
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a (ZonkAny 3)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from

-- | Extract the logical DuckDB type corresponding to a Haskell value.
genericLogicalType :: forall a. (Generic a, GToField (Rep a)) => Proxy a -> LogicalTypeRep
genericLogicalType :: forall a.
(Generic a, GToField (Rep a)) =>
Proxy a -> LogicalTypeRep
genericLogicalType Proxy a
_ = Proxy (Rep a ()) -> LogicalTypeRep
forall p. Proxy (Rep a p) -> LogicalTypeRep
forall (f :: * -> *) p. GToField f => Proxy (f p) -> LogicalTypeRep
gLogicalType (Proxy (Rep a ())
forall {k} (t :: k). Proxy t
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 :: forall a.
(Generic a, GFromField (Rep a)) =>
FieldValue -> Either String a
genericFromFieldValue FieldValue
fv = Rep a (ZonkAny 2) -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a (ZonkAny 2) -> a)
-> Either String (Rep a (ZonkAny 2)) -> Either String a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldValue -> Either String (Rep a (ZonkAny 2))
forall p. FieldValue -> Either String (Rep a p)
forall (f :: * -> *) p.
GFromField f =>
FieldValue -> Either String (f p)
gFromField FieldValue
fv

-- | Convenience helpers that project out structured values directly.
genericToStructValue :: forall a. (Generic a, GToField (Rep a)) => a -> Maybe (StructValue FieldValue)
genericToStructValue :: forall a.
(Generic a, GToField (Rep a)) =>
a -> Maybe (StructValue FieldValue)
genericToStructValue a
value =
    case Rep a (ZonkAny 1) -> Encoded
forall p. Rep a p -> Encoded
forall (f :: * -> *) p. GToField f => f p -> Encoded
gToField (a -> Rep a (ZonkAny 1)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from a
value) of
        EncodedStruct StructValue FieldValue
sv Array Int (StructField LogicalTypeRep)
_ -> StructValue FieldValue -> Maybe (StructValue FieldValue)
forall a. a -> Maybe a
Just StructValue FieldValue
sv
        Encoded
EncodedNull -> StructValue FieldValue -> Maybe (StructValue FieldValue)
forall a. a -> Maybe a
Just StructValue FieldValue
forall {a}. StructValue a
emptyStruct
        Encoded
_ -> Maybe (StructValue FieldValue)
forall a. Maybe a
Nothing
  where
    emptyStruct :: StructValue a
emptyStruct =
        StructValue
            { structValueFields :: Array Int (StructField a)
structValueFields = (Int, Int) -> [StructField a] -> Array Int (StructField a)
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, -Int
1) []
            , structValueTypes :: Array Int (StructField LogicalTypeRep)
structValueTypes = (Int, Int)
-> [StructField LogicalTypeRep]
-> Array Int (StructField LogicalTypeRep)
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, -Int
1) []
            , structValueIndex :: Map Text Int
structValueIndex = Map Text Int
forall k a. Map k a
Map.empty
            }

-- | Extract a UNION-shaped generic encoding directly when one is produced.
genericToUnionValue :: forall a. (Generic a, GToField (Rep a)) => a -> Maybe (UnionValue FieldValue)
genericToUnionValue :: forall a.
(Generic a, GToField (Rep a)) =>
a -> Maybe (UnionValue FieldValue)
genericToUnionValue a
value =
    case Rep a (ZonkAny 0) -> Encoded
forall p. Rep a p -> Encoded
forall (f :: * -> *) p. GToField f => f p -> Encoded
gToField (a -> Rep a (ZonkAny 0)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from a
value) of
        EncodedUnion UnionValue FieldValue
uv -> UnionValue FieldValue -> Maybe (UnionValue FieldValue)
forall a. a -> Maybe a
Just UnionValue FieldValue
uv
        Encoded
_ -> Maybe (UnionValue FieldValue)
forall a. Maybe a
Nothing

{- | Wrapper for deriving-via so that @instance ToField (ViaDuckDB a)@ picks up
the generic encoding provided by this module.
-}
newtype ViaDuckDB a = ViaDuckDB {forall a. ViaDuckDB a -> a
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 :: forall p. f p -> Encoded
gToField = Proxy (IsSum f) -> f p -> Encoded
forall (isSum :: Bool) (f :: * -> *) p.
GToField' isSum f =>
Proxy isSum -> f p -> Encoded
forall p. Proxy (IsSum f) -> f p -> Encoded
gToField' (Proxy (IsSum f)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (IsSum f))
    gLogicalType :: forall p. Proxy (f p) -> LogicalTypeRep
gLogicalType Proxy (f p)
_ = Proxy (IsSum f) -> Proxy f -> LogicalTypeRep
forall (isSum :: Bool) (f :: * -> *).
GToField' isSum f =>
Proxy isSum -> Proxy f -> LogicalTypeRep
gLogicalType' (Proxy (IsSum f)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (IsSum f)) (Proxy f
forall {k} (t :: k). Proxy t
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' :: forall p. Proxy 'False -> M1 D meta (M1 C c f) p -> Encoded
gToField' Proxy 'False
_ (M1 (M1 f p
inner)) =
        let comps :: [FieldComponent FieldValue]
comps = f p -> [FieldComponent FieldValue]
forall p. f p -> [FieldComponent FieldValue]
forall (f :: * -> *) p.
GStruct f =>
f p -> [FieldComponent FieldValue]
gStructValues f p
inner
            typeComps :: [FieldComponent LogicalTypeRep]
typeComps = Proxy (f (ZonkAny 16)) -> [FieldComponent LogicalTypeRep]
forall p. Proxy (f p) -> [FieldComponent LogicalTypeRep]
forall (f :: * -> *) p.
GStruct f =>
Proxy (f p) -> [FieldComponent LogicalTypeRep]
gStructTypes (Proxy (f p)
forall {p}. Proxy (f p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f p))
         in case [FieldComponent FieldValue]
comps of
                [] -> Encoded
EncodedNull
                [FieldComponent FieldValue]
_ ->
                    let names :: [Text]
names = [(Int, Maybe Text)] -> [Text]
resolveNames ([Int] -> [Maybe Text] -> [(Int, Maybe Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
progIndices ((FieldComponent FieldValue -> Maybe Text)
-> [FieldComponent FieldValue] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map FieldComponent FieldValue -> Maybe Text
forall a. FieldComponent a -> Maybe Text
fcName [FieldComponent FieldValue]
comps))
                        valueArray :: Array Int (StructField FieldValue)
valueArray = [Text] -> [FieldValue] -> Array Int (StructField FieldValue)
forall b. [Text] -> [b] -> Array Int (StructField b)
listArrayFrom [Text]
names ((FieldComponent FieldValue -> FieldValue)
-> [FieldComponent FieldValue] -> [FieldValue]
forall a b. (a -> b) -> [a] -> [b]
map FieldComponent FieldValue -> FieldValue
forall a. FieldComponent a -> a
fcValue [FieldComponent FieldValue]
comps)
                        typeArray :: Array Int (StructField LogicalTypeRep)
typeArray = [Text]
-> [LogicalTypeRep] -> Array Int (StructField LogicalTypeRep)
forall b. [Text] -> [b] -> Array Int (StructField b)
listArrayFrom [Text]
names ((FieldComponent LogicalTypeRep -> LogicalTypeRep)
-> [FieldComponent LogicalTypeRep] -> [LogicalTypeRep]
forall a b. (a -> b) -> [a] -> [b]
map FieldComponent LogicalTypeRep -> LogicalTypeRep
forall a. FieldComponent a -> a
fcValue [FieldComponent LogicalTypeRep]
typeComps)
                        indexMap :: Map Text Int
indexMap = [(Text, Int)] -> Map Text Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Text] -> [Int] -> [(Text, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
names [Int
0 ..])
                     in StructValue FieldValue
-> Array Int (StructField LogicalTypeRep) -> Encoded
EncodedStruct
                            StructValue
                                { structValueFields :: Array Int (StructField FieldValue)
structValueFields = Array Int (StructField FieldValue)
valueArray
                                , structValueTypes :: Array Int (StructField LogicalTypeRep)
structValueTypes = Array Int (StructField LogicalTypeRep)
typeArray
                                , structValueIndex :: Map Text Int
structValueIndex = Map Text Int
indexMap
                                }
                            Array Int (StructField LogicalTypeRep)
typeArray
      where
        progIndices :: [Int]
progIndices = [Int
0 :: Int ..]
    gLogicalType' :: Proxy 'False -> Proxy (M1 D meta (M1 C c f)) -> LogicalTypeRep
gLogicalType' Proxy 'False
_ Proxy (M1 D meta (M1 C c f))
_ =
        let typeComps :: [FieldComponent LogicalTypeRep]
typeComps = Proxy (f (ZonkAny 17)) -> [FieldComponent LogicalTypeRep]
forall p. Proxy (f p) -> [FieldComponent LogicalTypeRep]
forall (f :: * -> *) p.
GStruct f =>
Proxy (f p) -> [FieldComponent LogicalTypeRep]
gStructTypes (Proxy (f p)
forall {p}. Proxy (f p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f p))
            names :: [Text]
names = [(Int, Maybe Text)] -> [Text]
resolveNames ([Int] -> [Maybe Text] -> [(Int, Maybe Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] ((FieldComponent LogicalTypeRep -> Maybe Text)
-> [FieldComponent LogicalTypeRep] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map FieldComponent LogicalTypeRep -> Maybe Text
forall a. FieldComponent a -> Maybe Text
fcName [FieldComponent LogicalTypeRep]
typeComps))
            typeArray :: Array Int (StructField LogicalTypeRep)
typeArray = [Text]
-> [LogicalTypeRep] -> Array Int (StructField LogicalTypeRep)
forall b. [Text] -> [b] -> Array Int (StructField b)
listArrayFrom [Text]
names ((FieldComponent LogicalTypeRep -> LogicalTypeRep)
-> [FieldComponent LogicalTypeRep] -> [LogicalTypeRep]
forall a b. (a -> b) -> [a] -> [b]
map FieldComponent LogicalTypeRep -> LogicalTypeRep
forall a. FieldComponent a -> a
fcValue [FieldComponent LogicalTypeRep]
typeComps)
         in Array Int (StructField LogicalTypeRep) -> LogicalTypeRep
LogicalTypeStruct Array Int (StructField LogicalTypeRep)
typeArray

-- Sums (encode as union)

-- | Sum encoding: multi-constructor datatypes become UNION values.
instance (GSum f) => GToField' 'True (M1 D meta f) where
    gToField' :: forall p. Proxy 'True -> M1 D meta f p -> Encoded
gToField' Proxy 'True
_ (M1 f p
value) =
        let members :: [UnionMemberType]
members = Proxy (f (ZonkAny 11)) -> [UnionMemberType]
forall p. Proxy (f p) -> [UnionMemberType]
forall (f :: * -> *) p. GSum f => Proxy (f p) -> [UnionMemberType]
gSumMembers (Proxy (f p)
forall {p}. Proxy (f p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f p))
            membersArray :: Array Int UnionMemberType
membersArray =
                case [UnionMemberType]
members of
                    [] -> (Int, Int) -> [UnionMemberType] -> Array Int UnionMemberType
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, -Int
1) []
                    [UnionMemberType]
_ -> (Int, Int) -> [UnionMemberType] -> Array Int UnionMemberType
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, [UnionMemberType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UnionMemberType]
members Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [UnionMemberType]
members
            (Int
idx, FieldValue
payload) = f p -> (Int, FieldValue)
forall p. f p -> (Int, FieldValue)
forall (f :: * -> *) p. GSum f => f p -> (Int, FieldValue)
gSumEncode f p
value
            label :: Text
label = UnionMemberType -> Text
unionMemberName ([UnionMemberType]
members [UnionMemberType] -> Int -> UnionMemberType
forall a. HasCallStack => [a] -> Int -> a
!! Int
idx)
         in UnionValue FieldValue -> Encoded
EncodedUnion
                UnionValue
                    { unionValueIndex :: Word16
unionValueIndex = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
idx
                    , unionValueLabel :: Text
unionValueLabel = Text
label
                    , unionValuePayload :: FieldValue
unionValuePayload = FieldValue
payload
                    , unionValueMembers :: Array Int UnionMemberType
unionValueMembers = Array Int UnionMemberType
membersArray
                    }
    gLogicalType' :: Proxy 'True -> Proxy (M1 D meta f) -> LogicalTypeRep
gLogicalType' Proxy 'True
_ Proxy (M1 D meta f)
_ =
        let members :: [UnionMemberType]
members = Proxy (f (ZonkAny 12)) -> [UnionMemberType]
forall p. Proxy (f p) -> [UnionMemberType]
forall (f :: * -> *) p. GSum f => Proxy (f p) -> [UnionMemberType]
gSumMembers (Proxy (f p)
forall {p}. Proxy (f p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f p))
            membersArray :: Array Int UnionMemberType
membersArray =
                case [UnionMemberType]
members of
                    [] -> (Int, Int) -> [UnionMemberType] -> Array Int UnionMemberType
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, -Int
1) []
                    [UnionMemberType]
_ -> (Int, Int) -> [UnionMemberType] -> Array Int UnionMemberType
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, [UnionMemberType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [UnionMemberType]
members Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [UnionMemberType]
members
         in Array Int UnionMemberType -> LogicalTypeRep
LogicalTypeUnion Array Int UnionMemberType
membersArray

--------------------------------------------------------------------------------
-- GStruct: products

data FieldComponent a = FieldComponent
    { forall a. FieldComponent a -> Maybe Text
fcName :: Maybe Text
    , forall a. FieldComponent a -> a
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 :: [(Int, Maybe Text)] -> [Text]
resolveNames =
    ((Int, Maybe Text) -> Text) -> [(Int, Maybe Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Maybe Text) -> Text
forall {a}. (Show a, Num a) => (a, Maybe Text) -> Text
pick
  where
    pick :: (a, Maybe Text) -> Text
pick (a
_, Just Text
n) = Text
n
    pick (a
idx, Maybe Text
Nothing) = String -> Text
Text.pack (String
"field" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show (a
idx a -> a -> a
forall a. Num a => a -> a -> a
+ a
1))

{- | Helper that builds an @Array@ of struct fields from parallel lists of names
and payloads.
-}
listArrayFrom :: [Text] -> [b] -> Array Int (StructField b)
listArrayFrom :: forall b. [Text] -> [b] -> Array Int (StructField b)
listArrayFrom [Text]
names [b]
values =
    case [b]
values of
        [] -> (Int, Int) -> [StructField b] -> Array Int (StructField b)
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, -Int
1) []
        [b]
_ ->
            (Int, Int) -> [StructField b] -> Array Int (StructField b)
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray
                (Int
0, [b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
values Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                ((Text -> b -> StructField b) -> [Text] -> [b] -> [StructField b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Text
n b
v -> StructField{structFieldName :: Text
structFieldName = Text
n, structFieldValue :: b
structFieldValue = b
v}) [Text]
names [b]
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 :: forall p. U1 p -> [FieldComponent FieldValue]
gStructValues U1 p
_ = []
    gStructTypes :: forall p. Proxy (U1 p) -> [FieldComponent LogicalTypeRep]
gStructTypes Proxy (U1 p)
_ = []

instance (GStruct a, GStruct b) => GStruct (a :*: b) where
    gStructValues :: forall p. (:*:) a b p -> [FieldComponent FieldValue]
gStructValues (a p
a :*: b p
b) = a p -> [FieldComponent FieldValue]
forall p. a p -> [FieldComponent FieldValue]
forall (f :: * -> *) p.
GStruct f =>
f p -> [FieldComponent FieldValue]
gStructValues a p
a [FieldComponent FieldValue]
-> [FieldComponent FieldValue] -> [FieldComponent FieldValue]
forall a. [a] -> [a] -> [a]
++ b p -> [FieldComponent FieldValue]
forall p. b p -> [FieldComponent FieldValue]
forall (f :: * -> *) p.
GStruct f =>
f p -> [FieldComponent FieldValue]
gStructValues b p
b
    gStructTypes :: forall p. Proxy ((:*:) a b p) -> [FieldComponent LogicalTypeRep]
gStructTypes Proxy ((:*:) a b p)
_ = Proxy (a (ZonkAny 14)) -> [FieldComponent LogicalTypeRep]
forall p. Proxy (a p) -> [FieldComponent LogicalTypeRep]
forall (f :: * -> *) p.
GStruct f =>
Proxy (f p) -> [FieldComponent LogicalTypeRep]
gStructTypes (Proxy (a p)
forall {p}. Proxy (a p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (a p)) [FieldComponent LogicalTypeRep]
-> [FieldComponent LogicalTypeRep]
-> [FieldComponent LogicalTypeRep]
forall a. [a] -> [a] -> [a]
++ Proxy (b (ZonkAny 15)) -> [FieldComponent LogicalTypeRep]
forall p. Proxy (b p) -> [FieldComponent LogicalTypeRep]
forall (f :: * -> *) p.
GStruct f =>
Proxy (f p) -> [FieldComponent LogicalTypeRep]
gStructTypes (Proxy (b p)
forall {p}. Proxy (b p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (b p))

instance (Selector s, DuckValue a) => GStruct (M1 S s (K1 i a)) where
    gStructValues :: forall p. M1 S s (K1 i a) p -> [FieldComponent FieldValue]
gStructValues m :: M1 S s (K1 i a) p
m@(M1 (K1 a
x)) =
        let name :: Maybe Text
name = String -> Maybe Text
toMaybe (M1 S s (K1 i a) p -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName M1 S s (K1 i a) p
m)
         in [Maybe Text -> FieldValue -> FieldComponent FieldValue
forall a. Maybe Text -> a -> FieldComponent a
FieldComponent Maybe Text
name (a -> FieldValue
forall a. DuckValue a => a -> FieldValue
duckToField a
x)]
    gStructTypes :: forall p.
Proxy (M1 S s (K1 i a) p) -> [FieldComponent LogicalTypeRep]
gStructTypes Proxy (M1 S s (K1 i a) p)
_ =
        let raw :: String
raw = M1 S s (K1 i a) () -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t s f a -> String
selName (M1 S s (K1 i a) ()
forall a. HasCallStack => a
undefined :: M1 S s (K1 i a) ())
            name :: Maybe Text
name = String -> Maybe Text
toMaybe String
raw
         in [Maybe Text -> LogicalTypeRep -> FieldComponent LogicalTypeRep
forall a. Maybe Text -> a -> FieldComponent a
FieldComponent Maybe Text
name (Proxy a -> LogicalTypeRep
forall a. DuckValue a => Proxy a -> LogicalTypeRep
duckLogicalType (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a))]

instance (GStruct f) => GStruct (M1 C c f) where
    gStructValues :: forall p. M1 C c f p -> [FieldComponent FieldValue]
gStructValues (M1 f p
x) = f p -> [FieldComponent FieldValue]
forall p. f p -> [FieldComponent FieldValue]
forall (f :: * -> *) p.
GStruct f =>
f p -> [FieldComponent FieldValue]
gStructValues f p
x
    gStructTypes :: forall p. Proxy (M1 C c f p) -> [FieldComponent LogicalTypeRep]
gStructTypes Proxy (M1 C c f p)
_ = Proxy (f (ZonkAny 13)) -> [FieldComponent LogicalTypeRep]
forall p. Proxy (f p) -> [FieldComponent LogicalTypeRep]
forall (f :: * -> *) p.
GStruct f =>
Proxy (f p) -> [FieldComponent LogicalTypeRep]
gStructTypes (Proxy (f p)
forall {p}. Proxy (f p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f p))

toMaybe :: String -> Maybe Text
toMaybe :: String -> Maybe Text
toMaybe String
name
    | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
name = Maybe Text
forall a. Maybe a
Nothing
    | Bool
otherwise = Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
Text.pack String
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 :: forall p. Proxy ((:+:) a b p) -> [UnionMemberType]
gSumMembers Proxy ((:+:) a b p)
_ = Proxy (a (ZonkAny 7)) -> [UnionMemberType]
forall p. Proxy (a p) -> [UnionMemberType]
forall (f :: * -> *) p. GSum f => Proxy (f p) -> [UnionMemberType]
gSumMembers (Proxy (a p)
forall {p}. Proxy (a p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (a p)) [UnionMemberType] -> [UnionMemberType] -> [UnionMemberType]
forall a. [a] -> [a] -> [a]
++ Proxy (b (ZonkAny 8)) -> [UnionMemberType]
forall p. Proxy (b p) -> [UnionMemberType]
forall (f :: * -> *) p. GSum f => Proxy (f p) -> [UnionMemberType]
gSumMembers (Proxy (b p)
forall {p}. Proxy (b p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (b p))
    gSumEncode :: forall p. (:+:) a b p -> (Int, FieldValue)
gSumEncode (L1 a p
x) = a p -> (Int, FieldValue)
forall p. a p -> (Int, FieldValue)
forall (f :: * -> *) p. GSum f => f p -> (Int, FieldValue)
gSumEncode a p
x
    gSumEncode (R1 b p
x) =
        let leftCount :: Int
leftCount = [UnionMemberType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Proxy (a (ZonkAny 9)) -> [UnionMemberType]
forall p. Proxy (a p) -> [UnionMemberType]
forall (f :: * -> *) p. GSum f => Proxy (f p) -> [UnionMemberType]
gSumMembers (Proxy (a p)
forall {p}. Proxy (a p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (a p)))
            (Int
idx, FieldValue
payload) = b p -> (Int, FieldValue)
forall p. b p -> (Int, FieldValue)
forall (f :: * -> *) p. GSum f => f p -> (Int, FieldValue)
gSumEncode b p
x
         in (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
leftCount, FieldValue
payload)
    gSumDecode :: forall p. Int -> FieldValue -> Either String ((:+:) a b p)
gSumDecode Int
idx FieldValue
payload =
        let leftCount :: Int
leftCount = [UnionMemberType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Proxy (a (ZonkAny 10)) -> [UnionMemberType]
forall p. Proxy (a p) -> [UnionMemberType]
forall (f :: * -> *) p. GSum f => Proxy (f p) -> [UnionMemberType]
gSumMembers (Proxy (a p)
forall {p}. Proxy (a p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (a p)))
         in if Int
idx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
leftCount
                then a p -> (:+:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (a p -> (:+:) a b p)
-> Either String (a p) -> Either String ((:+:) a b p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> FieldValue -> Either String (a p)
forall p. Int -> FieldValue -> Either String (a p)
forall (f :: * -> *) p.
GSum f =>
Int -> FieldValue -> Either String (f p)
gSumDecode Int
idx FieldValue
payload
                else b p -> (:+:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (b p -> (:+:) a b p)
-> Either String (b p) -> Either String ((:+:) a b p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> FieldValue -> Either String (b p)
forall p. Int -> FieldValue -> Either String (b p)
forall (f :: * -> *) p.
GSum f =>
Int -> FieldValue -> Either String (f p)
gSumDecode (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
leftCount) FieldValue
payload

instance (Constructor c, GStruct f, GStructDecode f) => GSum (M1 C c f) where
    gSumMembers :: forall p. Proxy (M1 C c f p) -> [UnionMemberType]
gSumMembers Proxy (M1 C c f p)
_ =
        [ UnionMemberType
            { unionMemberName :: Text
unionMemberName = String -> Text
Text.pack (M1 C c f (ZonkAny 4) -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> String
conName (M1 C c f p
forall {p}. M1 C c f p
forall a. HasCallStack => a
undefined :: M1 C c f p))
            , unionMemberType :: LogicalTypeRep
unionMemberType =
                let typeComps :: [FieldComponent LogicalTypeRep]
typeComps = Proxy (f (ZonkAny 5)) -> [FieldComponent LogicalTypeRep]
forall p. Proxy (f p) -> [FieldComponent LogicalTypeRep]
forall (f :: * -> *) p.
GStruct f =>
Proxy (f p) -> [FieldComponent LogicalTypeRep]
gStructTypes (Proxy (f p)
forall {p}. Proxy (f p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f p))
                    names :: [Text]
names = [(Int, Maybe Text)] -> [Text]
resolveNames ([Int] -> [Maybe Text] -> [(Int, Maybe Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] ((FieldComponent LogicalTypeRep -> Maybe Text)
-> [FieldComponent LogicalTypeRep] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map FieldComponent LogicalTypeRep -> Maybe Text
forall a. FieldComponent a -> Maybe Text
fcName [FieldComponent LogicalTypeRep]
typeComps))
                 in Array Int (StructField LogicalTypeRep) -> LogicalTypeRep
LogicalTypeStruct ([Text]
-> [LogicalTypeRep] -> Array Int (StructField LogicalTypeRep)
forall b. [Text] -> [b] -> Array Int (StructField b)
listArrayFrom [Text]
names ((FieldComponent LogicalTypeRep -> LogicalTypeRep)
-> [FieldComponent LogicalTypeRep] -> [LogicalTypeRep]
forall a b. (a -> b) -> [a] -> [b]
map FieldComponent LogicalTypeRep -> LogicalTypeRep
forall a. FieldComponent a -> a
fcValue [FieldComponent LogicalTypeRep]
typeComps))
            }
        ]
    gSumEncode :: forall p. M1 C c f p -> (Int, FieldValue)
gSumEncode (M1 f p
x) =
        case f p -> [FieldComponent FieldValue]
forall p. f p -> [FieldComponent FieldValue]
forall (f :: * -> *) p.
GStruct f =>
f p -> [FieldComponent FieldValue]
gStructValues f p
x of
            [] -> (Int
0, FieldValue
FieldNull)
            [FieldComponent FieldValue]
comps ->
                let typeComps :: [FieldComponent LogicalTypeRep]
typeComps = Proxy (f (ZonkAny 6)) -> [FieldComponent LogicalTypeRep]
forall p. Proxy (f p) -> [FieldComponent LogicalTypeRep]
forall (f :: * -> *) p.
GStruct f =>
Proxy (f p) -> [FieldComponent LogicalTypeRep]
gStructTypes (Proxy (f p)
forall {p}. Proxy (f p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f p))
                    names :: [Text]
names = [(Int, Maybe Text)] -> [Text]
resolveNames ([Int] -> [Maybe Text] -> [(Int, Maybe Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] ((FieldComponent FieldValue -> Maybe Text)
-> [FieldComponent FieldValue] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map FieldComponent FieldValue -> Maybe Text
forall a. FieldComponent a -> Maybe Text
fcName [FieldComponent FieldValue]
comps))
                    valueArray :: Array Int (StructField FieldValue)
valueArray = [Text] -> [FieldValue] -> Array Int (StructField FieldValue)
forall b. [Text] -> [b] -> Array Int (StructField b)
listArrayFrom [Text]
names ((FieldComponent FieldValue -> FieldValue)
-> [FieldComponent FieldValue] -> [FieldValue]
forall a b. (a -> b) -> [a] -> [b]
map FieldComponent FieldValue -> FieldValue
forall a. FieldComponent a -> a
fcValue [FieldComponent FieldValue]
comps)
                    typeArray :: Array Int (StructField LogicalTypeRep)
typeArray = [Text]
-> [LogicalTypeRep] -> Array Int (StructField LogicalTypeRep)
forall b. [Text] -> [b] -> Array Int (StructField b)
listArrayFrom [Text]
names ((FieldComponent LogicalTypeRep -> LogicalTypeRep)
-> [FieldComponent LogicalTypeRep] -> [LogicalTypeRep]
forall a b. (a -> b) -> [a] -> [b]
map FieldComponent LogicalTypeRep -> LogicalTypeRep
forall a. FieldComponent a -> a
fcValue [FieldComponent LogicalTypeRep]
typeComps)
                    indexMap :: Map Text Int
indexMap = [(Text, Int)] -> Map Text Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Text] -> [Int] -> [(Text, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
names [Int
0 ..])
                 in (Int
0, StructValue FieldValue -> FieldValue
FieldStruct StructValue{structValueFields :: Array Int (StructField FieldValue)
structValueFields = Array Int (StructField FieldValue)
valueArray, structValueTypes :: Array Int (StructField LogicalTypeRep)
structValueTypes = Array Int (StructField LogicalTypeRep)
typeArray, structValueIndex :: Map Text Int
structValueIndex = Map Text Int
indexMap})
    gSumDecode :: forall p. Int -> FieldValue -> Either String (M1 C c f p)
gSumDecode Int
idx FieldValue
payload
        | Int
idx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = String -> Either String (M1 C c f p)
forall a b. a -> Either a b
Left (String
"duckdb-simple: union tag mismatch (expected 0, got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
idx String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")")
        | Bool
otherwise =
            case FieldValue
payload of
                FieldValue
FieldNull -> M1 C c f p -> Either String (M1 C c f p)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f p -> M1 C c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Proxy (f p) -> f p
forall p. Proxy (f p) -> f p
forall (f :: * -> *) p. GStructDecode f => Proxy (f p) -> f p
gStructNull (Proxy (f p)
forall {p}. Proxy (f p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f p))))
                FieldStruct StructValue FieldValue
structVal -> f p -> M1 C c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 C c f p)
-> Either String (f p) -> Either String (M1 C c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy (f p) -> StructValue FieldValue -> Either String (f p)
forall p.
Proxy (f p) -> StructValue FieldValue -> Either String (f p)
forall (f :: * -> *) p.
GStructDecode f =>
Proxy (f p) -> StructValue FieldValue -> Either String (f p)
gStructDecodeStruct (Proxy (f p)
forall {p}. Proxy (f p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f p)) StructValue FieldValue
structVal
                FieldValue
other -> String -> Either String (M1 C c f p)
forall a b. a -> Either a b
Left (String
"duckdb-simple: expected STRUCT payload for union member, got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> FieldValue -> String
forall a. Show a => a -> String
show FieldValue
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 :: forall p.
Proxy (U1 p) -> StructValue FieldValue -> Either String (U1 p)
gStructDecodeStruct Proxy (U1 p)
_ StructValue FieldValue
structVal =
        if [StructField FieldValue] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Array Int (StructField FieldValue) -> [StructField FieldValue]
forall i e. Array i e -> [e]
elems (StructValue FieldValue -> Array Int (StructField FieldValue)
forall a. StructValue a -> Array Int (StructField a)
structValueFields StructValue FieldValue
structVal))
            then U1 p -> Either String (U1 p)
forall a b. b -> Either a b
Right U1 p
forall k (p :: k). U1 p
U1
            else String -> Either String (U1 p)
forall a b. a -> Either a b
Left (String
"duckdb-simple: expected empty struct, but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([StructField FieldValue] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Array Int (StructField FieldValue) -> [StructField FieldValue]
forall i e. Array i e -> [e]
elems (StructValue FieldValue -> Array Int (StructField FieldValue)
forall a. StructValue a -> Array Int (StructField a)
structValueFields StructValue FieldValue
structVal))) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" field(s)")
    gStructNull :: forall p. Proxy (U1 p) -> U1 p
gStructNull Proxy (U1 p)
_ = U1 p
forall k (p :: k). U1 p
U1
    gStructDecodeList :: forall p.
Proxy (U1 p) -> [FieldValue] -> Either String (U1 p, [FieldValue])
gStructDecodeList Proxy (U1 p)
_ [FieldValue]
xs = (U1 p, [FieldValue]) -> Either String (U1 p, [FieldValue])
forall a b. b -> Either a b
Right (U1 p
forall k (p :: k). U1 p
U1, [FieldValue]
xs)

instance (GStructDecode a, GStructDecode b) => GStructDecode (a :*: b) where
    gStructDecodeStruct :: forall p.
Proxy ((:*:) a b p)
-> StructValue FieldValue -> Either String ((:*:) a b p)
gStructDecodeStruct Proxy ((:*:) a b p)
_ StructValue FieldValue
structVal = do
        let values :: [FieldValue]
values = (StructField FieldValue -> FieldValue)
-> [StructField FieldValue] -> [FieldValue]
forall a b. (a -> b) -> [a] -> [b]
map StructField FieldValue -> FieldValue
forall a. StructField a -> a
structFieldValue (Array Int (StructField FieldValue) -> [StructField FieldValue]
forall i e. Array i e -> [e]
elems (StructValue FieldValue -> Array Int (StructField FieldValue)
forall a. StructValue a -> Array Int (StructField a)
structValueFields StructValue FieldValue
structVal))
        (leftVal, rest) <- Proxy (a p) -> [FieldValue] -> Either String (a p, [FieldValue])
forall p.
Proxy (a p) -> [FieldValue] -> Either String (a p, [FieldValue])
forall (f :: * -> *) p.
GStructDecode f =>
Proxy (f p) -> [FieldValue] -> Either String (f p, [FieldValue])
gStructDecodeList (Proxy (a p)
forall {p}. Proxy (a p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (a p)) [FieldValue]
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 :: forall p. Proxy ((:*:) a b p) -> (:*:) a b p
gStructNull Proxy ((:*:) a b p)
_ = Proxy (a p) -> a p
forall p. Proxy (a p) -> a p
forall (f :: * -> *) p. GStructDecode f => Proxy (f p) -> f p
gStructNull (Proxy (a p)
forall {p}. Proxy (a p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (a p)) a p -> b p -> (:*:) a b p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: Proxy (b p) -> b p
forall p. Proxy (b p) -> b p
forall (f :: * -> *) p. GStructDecode f => Proxy (f p) -> f p
gStructNull (Proxy (b p)
forall {p}. Proxy (b p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (b p))
    gStructDecodeList :: forall p.
Proxy ((:*:) a b p)
-> [FieldValue] -> Either String ((:*:) a b p, [FieldValue])
gStructDecodeList Proxy ((:*:) a b p)
_ [FieldValue]
xs = do
        (leftVal, rest) <- Proxy (a p) -> [FieldValue] -> Either String (a p, [FieldValue])
forall p.
Proxy (a p) -> [FieldValue] -> Either String (a p, [FieldValue])
forall (f :: * -> *) p.
GStructDecode f =>
Proxy (f p) -> [FieldValue] -> Either String (f p, [FieldValue])
gStructDecodeList (Proxy (a p)
forall {p}. Proxy (a p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (a p)) [FieldValue]
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 :: forall p.
Proxy (M1 S s (K1 i a) p)
-> StructValue FieldValue -> Either String (M1 S s (K1 i a) p)
gStructDecodeStruct Proxy (M1 S s (K1 i a) p)
_ StructValue FieldValue
structVal =
        case (StructField FieldValue -> FieldValue)
-> [StructField FieldValue] -> [FieldValue]
forall a b. (a -> b) -> [a] -> [b]
map StructField FieldValue -> FieldValue
forall a. StructField a -> a
structFieldValue (Array Int (StructField FieldValue) -> [StructField FieldValue]
forall i e. Array i e -> [e]
elems (StructValue FieldValue -> Array Int (StructField FieldValue)
forall a. StructValue a -> Array Int (StructField a)
structValueFields StructValue FieldValue
structVal)) of
            [FieldValue
fv] -> K1 i a p -> M1 S s (K1 i a) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 i a p -> M1 S s (K1 i a) p)
-> (a -> K1 i a p) -> a -> M1 S s (K1 i a) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> K1 i a p
forall k i c (p :: k). c -> K1 i c p
K1 (a -> M1 S s (K1 i a) p)
-> Either String a -> Either String (M1 S s (K1 i a) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldValue -> Either String a
forall a. DuckValue a => FieldValue -> Either String a
duckFromField FieldValue
fv
            [] -> String -> Either String (M1 S s (K1 i a) p)
forall a b. a -> Either a b
Left String
"duckdb-simple: missing struct field (expected 1, got 0)"
            [FieldValue]
xs -> String -> Either String (M1 S s (K1 i a) p)
forall a b. a -> Either a b
Left (String
"duckdb-simple: expected single field struct, but got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([FieldValue] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FieldValue]
xs) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" 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 :: forall p. Proxy (M1 S s (K1 i a) p) -> M1 S s (K1 i a) p
gStructNull Proxy (M1 S s (K1 i a) p)
_ = String -> M1 S s (K1 i a) p
forall a. HasCallStack => String -> a
error String
"duckdb-simple: impossible - gStructNull called on selector"
    gStructDecodeList :: forall p.
Proxy (M1 S s (K1 i a) p)
-> [FieldValue] -> Either String (M1 S s (K1 i a) p, [FieldValue])
gStructDecodeList Proxy (M1 S s (K1 i a) p)
_ [] = String -> Either String (M1 S s (K1 i a) p, [FieldValue])
forall a b. a -> Either a b
Left String
"duckdb-simple: missing struct field (expected field but list is empty)"
    gStructDecodeList Proxy (M1 S s (K1 i a) p)
_ (FieldValue
fv : [FieldValue]
rest) = do
        val <- FieldValue -> Either String a
forall a. DuckValue a => FieldValue -> Either String a
duckFromField FieldValue
fv
        pure (M1 (K1 val), rest)

instance (GStructDecode f) => GStructDecode (M1 C c f) where
    gStructDecodeStruct :: forall p.
Proxy (M1 C c f p)
-> StructValue FieldValue -> Either String (M1 C c f p)
gStructDecodeStruct Proxy (M1 C c f p)
_ StructValue FieldValue
structVal = f p -> M1 C c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 C c f p)
-> Either String (f p) -> Either String (M1 C c f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy (f p) -> StructValue FieldValue -> Either String (f p)
forall p.
Proxy (f p) -> StructValue FieldValue -> Either String (f p)
forall (f :: * -> *) p.
GStructDecode f =>
Proxy (f p) -> StructValue FieldValue -> Either String (f p)
gStructDecodeStruct (Proxy (f p)
forall {p}. Proxy (f p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f p)) StructValue FieldValue
structVal
    gStructNull :: forall p. Proxy (M1 C c f p) -> M1 C c f p
gStructNull Proxy (M1 C c f p)
_ = f p -> M1 C c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Proxy (f p) -> f p
forall p. Proxy (f p) -> f p
forall (f :: * -> *) p. GStructDecode f => Proxy (f p) -> f p
gStructNull (Proxy (f p)
forall {p}. Proxy (f p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f p)))
    gStructDecodeList :: forall p.
Proxy (M1 C c f p)
-> [FieldValue] -> Either String (M1 C c f p, [FieldValue])
gStructDecodeList Proxy (M1 C c f p)
_ [FieldValue]
values = do
        (inner, rest) <- Proxy (f p) -> [FieldValue] -> Either String (f p, [FieldValue])
forall p.
Proxy (f p) -> [FieldValue] -> Either String (f p, [FieldValue])
forall (f :: * -> *) p.
GStructDecode f =>
Proxy (f p) -> [FieldValue] -> Either String (f p, [FieldValue])
gStructDecodeList (Proxy (f p)
forall {p}. Proxy (f p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f p)) [FieldValue]
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 :: forall p. FieldValue -> Either String (f p)
gFromField = Proxy (IsSum f) -> FieldValue -> Either String (f p)
forall (isSum :: Bool) (f :: * -> *) p.
GFromField' isSum f =>
Proxy isSum -> FieldValue -> Either String (f p)
forall p. Proxy (IsSum f) -> FieldValue -> Either String (f p)
gFromField' (Proxy (IsSum f)
forall {k} (t :: k). Proxy t
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' :: forall p.
Proxy 'False
-> FieldValue -> Either String (M1 D meta (M1 C c f) p)
gFromField' Proxy 'False
_ = \case
        FieldValue
FieldNull -> M1 D meta (M1 C c f) p -> Either String (M1 D meta (M1 C c f) p)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (M1 C c f p -> M1 D meta (M1 C c f) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 C c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Proxy (f p) -> f p
forall p. Proxy (f p) -> f p
forall (f :: * -> *) p. GStructDecode f => Proxy (f p) -> f p
gStructNull (Proxy (f p)
forall {p}. Proxy (f p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f p)))))
        FieldStruct StructValue FieldValue
sv -> M1 C c f p -> M1 D meta (M1 C c f) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (M1 C c f p -> M1 D meta (M1 C c f) p)
-> (f p -> M1 C c f p) -> f p -> M1 D meta (M1 C c f) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f p -> M1 C c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 D meta (M1 C c f) p)
-> Either String (f p) -> Either String (M1 D meta (M1 C c f) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy (f p) -> StructValue FieldValue -> Either String (f p)
forall p.
Proxy (f p) -> StructValue FieldValue -> Either String (f p)
forall (f :: * -> *) p.
GStructDecode f =>
Proxy (f p) -> StructValue FieldValue -> Either String (f p)
gStructDecodeStruct (Proxy (f p)
forall {p}. Proxy (f p)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (f p)) StructValue FieldValue
sv
        FieldValue
other -> String -> Either String (M1 D meta (M1 C c f) p)
forall a b. a -> Either a b
Left (String
"duckdb-simple: expected STRUCT value for product type, got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> FieldValue -> String
forall a. Show a => a -> String
show FieldValue
other)

instance (GSum f) => GFromField' 'True (M1 D meta f) where
    gFromField' :: forall p.
Proxy 'True -> FieldValue -> Either String (M1 D meta f p)
gFromField' Proxy 'True
_ = \case
        FieldUnion UnionValue FieldValue
uv -> f p -> M1 D meta f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 D meta f p)
-> Either String (f p) -> Either String (M1 D meta f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> FieldValue -> Either String (f p)
forall p. Int -> FieldValue -> Either String (f p)
forall (f :: * -> *) p.
GSum f =>
Int -> FieldValue -> Either String (f p)
gSumDecode (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (UnionValue FieldValue -> Word16
forall a. UnionValue a -> Word16
unionValueIndex UnionValue FieldValue
uv)) (UnionValue FieldValue -> FieldValue
forall a. UnionValue a -> a
unionValuePayload UnionValue FieldValue
uv)
        FieldValue
other -> String -> Either String (M1 D meta f p)
forall a b. a -> Either a b
Left (String
"duckdb-simple: expected UNION value for sum type, got " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> FieldValue -> String
forall a. Show a => a -> String
show FieldValue
other)

instance GFromField' 'False (M1 D meta U1) where
    gFromField' :: forall p.
Proxy 'False -> FieldValue -> Either String (M1 D meta U1 p)
gFromField' Proxy 'False
_ FieldValue
_ = M1 D meta U1 p -> Either String (M1 D meta U1 p)
forall a b. b -> Either a b
Right (U1 p -> M1 D meta U1 p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 U1 p
forall k (p :: k). U1 p
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 :: Proxy (ViaDuckDB a) -> Text
duckdbColumnTypeFor Proxy (ViaDuckDB a)
_ =
        case Proxy a -> LogicalTypeRep
forall a.
(Generic a, GToField (Rep a)) =>
Proxy a -> LogicalTypeRep
genericLogicalType (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a) of
            LogicalTypeStruct{} -> String -> Text
Text.pack String
"STRUCT"
            LogicalTypeUnion{} -> String -> Text
Text.pack String
"UNION"
            LogicalTypeList{} -> String -> Text
Text.pack String
"LIST"
            LogicalTypeArray{} -> String -> Text
Text.pack String
"ARRAY"
            LogicalTypeMap{} -> String -> Text
Text.pack String
"MAP"
            LogicalTypeScalar DuckDBType
dtype -> DuckDBType -> Text
duckdbTypeToName DuckDBType
dtype
            LogicalTypeDecimal{} -> String -> Text
Text.pack String
"DECIMAL"
            LogicalTypeEnum{} -> String -> Text
Text.pack String
"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 a -> FieldBinding
toField (ViaDuckDB a
x) =
        case a -> Maybe (UnionValue FieldValue)
forall a.
(Generic a, GToField (Rep a)) =>
a -> Maybe (UnionValue FieldValue)
genericToUnionValue a
x of
            Just UnionValue FieldValue
unionVal -> UnionValue FieldValue -> FieldBinding
forall a. ToField a => a -> FieldBinding
toField UnionValue FieldValue
unionVal
            Maybe (UnionValue FieldValue)
Nothing ->
                case a -> Maybe (StructValue FieldValue)
forall a.
(Generic a, GToField (Rep a)) =>
a -> Maybe (StructValue FieldValue)
genericToStructValue a
x of
                    Just StructValue FieldValue
structVal -> StructValue FieldValue -> FieldBinding
forall a. ToField a => a -> FieldBinding
toField StructValue FieldValue
structVal
                    Maybe (StructValue FieldValue)
Nothing ->
                        case a -> FieldValue
forall a. (Generic a, GToField (Rep a)) => a -> FieldValue
genericToFieldValue a
x of
                            FieldUnion UnionValue FieldValue
uv -> UnionValue FieldValue -> FieldBinding
forall a. ToField a => a -> FieldBinding
toField UnionValue FieldValue
uv
                            FieldStruct StructValue FieldValue
sv -> StructValue FieldValue -> FieldBinding
forall a. ToField a => a -> FieldBinding
toField StructValue FieldValue
sv
                            FieldValue
FieldNull -> Maybe Int -> FieldBinding
forall a. ToField a => a -> FieldBinding
toField (Maybe Int
forall a. Maybe a
Nothing :: Maybe Int)
                            FieldValue
other -> String -> FieldBinding
forall a. HasCallStack => String -> a
error (String
"duckdb-simple: unsupported generic encoding " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> FieldValue -> String
forall a. Show a => a -> String
show FieldValue
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 :: FieldParser (ViaDuckDB a)
fromField f :: Field
f@Field{FieldValue
fieldValue :: Field -> FieldValue
fieldValue :: FieldValue
fieldValue} =
        case FieldValue -> Either String a
forall a.
(Generic a, GFromField (Rep a)) =>
FieldValue -> Either String a
genericFromFieldValue FieldValue
fieldValue of
            Right a
value -> ViaDuckDB a -> Ok (ViaDuckDB a)
forall a. a -> Ok a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> ViaDuckDB a
forall a. a -> ViaDuckDB a
ViaDuckDB a
value)
            Left String
err ->
                (Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok (ViaDuckDB a)
forall b.
Typeable b =>
(Text -> Text -> Text -> Text -> ResultError)
-> Field -> Text -> Ok b
returnError Text -> Text -> Text -> Text -> ResultError
ConversionFailed Field
f (String -> Text
Text.pack String
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 :: DuckDBType -> Text
duckdbTypeToName DuckDBType
dtype
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeBoolean = String -> Text
Text.pack String
"BOOLEAN"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeTinyInt = String -> Text
Text.pack String
"TINYINT"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeSmallInt = String -> Text
Text.pack String
"SMALLINT"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeInteger = String -> Text
Text.pack String
"INTEGER"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeBigInt = String -> Text
Text.pack String
"BIGINT"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeUTinyInt = String -> Text
Text.pack String
"UTINYINT"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeUSmallInt = String -> Text
Text.pack String
"USMALLINT"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeUInteger = String -> Text
Text.pack String
"UINTEGER"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeUBigInt = String -> Text
Text.pack String
"UBIGINT"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeFloat = String -> Text
Text.pack String
"FLOAT"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeDouble = String -> Text
Text.pack String
"DOUBLE"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeVarchar = String -> Text
Text.pack String
"VARCHAR"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeBlob = String -> Text
Text.pack String
"BLOB"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeDate = String -> Text
Text.pack String
"DATE"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeTime = String -> Text
Text.pack String
"TIME"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeTimestamp = String -> Text
Text.pack String
"TIMESTAMP"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeTimestampTz = String -> Text
Text.pack String
"TIMESTAMP_TZ"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeUUID = String -> Text
Text.pack String
"UUID"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeInterval = String -> Text
Text.pack String
"INTERVAL"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeHugeInt = String -> Text
Text.pack String
"HUGEINT"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeUHugeInt = String -> Text
Text.pack String
"UHUGEINT"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeBigNum = String -> Text
Text.pack String
"BIGNUM"
    | DuckDBType
dtype DuckDBType -> DuckDBType -> Bool
forall a. Eq a => a -> a -> Bool
== DuckDBType
DuckDBTypeTimeTz = String -> Text
Text.pack String
"TIME_TZ"
    | Bool
otherwise = String -> Text
Text.pack (DuckDBType -> String
forall a. Show a => a -> String
show DuckDBType
dtype)

--------------------------------------------------------------------------------
-- DuckDB type constructors (re-exported patterns)

-- These pattern synonyms come from duckdb-ffi; re-exporting to avoid users having to import it.