@@ -25,6 +25,7 @@ Binary encoding and decoding between Haskell and PostgreSQL types.
2525 , ScopedTypeVariables
2626 , TypeApplications
2727 , TypeFamilies
28+ , TypeFamilyDependencies
2829 , TypeInType
2930 , TypeOperators
3031 , UndecidableInstances
@@ -43,6 +44,7 @@ module Squeal.PostgreSQL.Binary
4344 , Only (..)
4445 ) where
4546
47+import BinaryParser
4648import Data.Aeson hiding (Null)
4749import Data.Int
4850import Data.Kind
@@ -202,6 +204,63 @@ instance FromValue pg y => FromValue ('PGfixarray n pg) (Vector (Maybe y)) where
202204 (Decoding.dimensionArray Vector.replicateM
203205 (Decoding.nullableValueArray (fromValue (Proxy @pg))))
204206
207+class IsMaybes (xs :: [Type]) where
208+ type family Maybes xs = (mxs :: [Type]) | mxs -> xs
209+ maybes :: NP Maybe xs -> NP I (Maybes xs)
210+
211+instance IsMaybes '[] where
212+ type Maybes '[] = '[]
213+ maybes Nil = Nil
214+
215+instance IsMaybes xs => IsMaybes (x ': xs) where
216+ type Maybes (x ': xs) = Maybe x ': Maybes xs
217+ maybes (x :* xs) = I x :* maybes xs
218+
219+class FromAliasedValue (pg :: (Symbol,PGType)) (y :: Type) where
220+ fromAliasedValue :: proxy pg -> Decoding.Value y
221+instance FromValue pg y => FromAliasedValue (alias ::: pg) y where
222+ fromAliasedValue _ = fromValue (Proxy @pg)
223+
224+instance
225+ ( SListI fields
226+ , IsMaybes ys
227+ , IsProductType y (Maybes ys)
228+ , AllZip FromAliasedValue fields ys
229+ , SameFields (DatatypeInfoOf y) fields
230+ ) => FromValue ('PGcomposite fields) y where
231+ fromValue = fmap (to . SOP . Z . maybes) . composite . decoders
232+
233+decoders
234+ :: forall pgs ys proxy
235+ . AllZip FromAliasedValue pgs ys
236+ => proxy ('PGcomposite pgs)
237+ -> NP Decoding.Value ys
238+decoders _ = htrans (Proxy @FromAliasedValue) fromAliasedValue
239+ (hpure Proxy :: NP Proxy pgs)
240+
241+composite
242+ :: SListI ys
243+ => NP Decoding.Value ys
244+ -> Decoding.Value (NP Maybe ys)
245+composite decoders = do
246+-- [for each field]
247+-- <OID of field's type: sizeof(Oid) bytes>
248+-- [if value is NULL]
249+-- <-1: 4 bytes>
250+-- [else]
251+-- <length of value: 4 bytes>
252+-- <value: <length> bytes>
253+-- [end if]
254+-- [end for]
255+-- <number of fields: 4 bytes>
256+ unitOfSize 4
257+ let
258+ each decoder = do
259+ unitOfSize 4
260+ len <- sized 4 Decoding.int
261+ if len == -1 then return Nothing else Just <$> sized len decoder
262+ htraverse' each decoders
263+
205264-- | A `FromColumnValue` constraint lifts the `FromValue` parser
206265-- to a decoding of a @(Symbol, ColumnType)@ to a `Type`,
207266-- decoding `Null`s to `Maybe`s. You should not define instances for