ArrayField

morphismtech · Sep 12, 2024 · e8b97a9 · e8b97a9
1 parent 6b790f2
commit e8b97a9
Show file tree

Hide file tree

Showing 2 changed files with 37 additions and 1 deletion.
diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Session.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Session.hs
@@ -44,7 +44,6 @@ import Control.Monad (MonadPlus(..))
 import Control.Monad.Base (MonadBase(..))
 import Control.Monad.Fix (MonadFix(..))
 import Control.Monad.Catch
-import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Morph
 import Control.Monad.Reader
 import Control.Monad.Trans.Control (MonadBaseControl(..), MonadTransControl(..))

diff --git a/squeal-postgresql/src/Squeal/PostgreSQL/Session/Decode.hs b/squeal-postgresql/src/Squeal/PostgreSQL/Session/Decode.hs
@@ -43,6 +43,7 @@ module Squeal.PostgreSQL.Session.Decode
   , genericProductRow
   , appendRows
   , consRow
+  , ArrayField (..)
     -- * Decoding Classes
   , FromValue (..)
   , FromField (..)
@@ -533,6 +534,42 @@ instance {-# OVERLAPPABLE #-} IsLabel fld (MaybeT (DecodeRow row) y)
     fromLabel = MaybeT . decodeRow $ \(_ SOP.:* bs) ->
       runDecodeRow (runMaybeT (fromLabel @fld)) bs
 
+{- | Utility for decoding array fields in a `DecodeRow`,
+accessed via overloaded labels.
+-}
+newtype ArrayField row y = ArrayField
+  { runArrayField
+      :: StateT Strict.ByteString (Except Strict.Text) y
+      -> DecodeRow row [y]
+  }
+instance {-# OVERLAPPING #-}
+  ( KnownSymbol fld
+  , PG y ~ ty
+  , arr ~ 'NotNull ('PGvararray ('NotNull ty))
+  ) => IsLabel fld (ArrayField (fld ::: arr ': row) y) where
+    fromLabel = ArrayField $ \yval ->
+      decodeRow $ \(SOP.K bytesMaybe SOP.:* _) -> do
+        let
+          flderr = mconcat
+            [ "field name: "
+            , "\"", fromString (symbolVal (SOP.Proxy @fld)), "\"; "
+            ]
+          yarr
+            = devalue
+            . array
+            . dimensionArray replicateM
+            . valueArray
+            . revalue
+            $ yval
+        case bytesMaybe of
+          Nothing -> Left (flderr <> "encountered unexpected NULL")
+          Just bytes -> runExcept (evalStateT yarr bytes)
+instance {-# OVERLAPPABLE #-} IsLabel fld (ArrayField row y)
+  => IsLabel fld (ArrayField (field ': row) y) where
+    fromLabel = ArrayField $ \yval ->
+      decodeRow $ \(_ SOP.:* bytess) ->
+        runDecodeRow (runArrayField (fromLabel @fld) yval) bytess
+
 -- | A `GenericRow` constraint to ensure that a Haskell type
 -- is a record type,
 -- has a `RowPG`,