feat(users/Profpatsch/my-prelude): update libraries

The latest and greatest!

Change-Id: I34c0e9f41b3b3cc727d9ea89c7ce6a43271b3170
Reviewed-on: https://cl.tvl.fyi/c/depot/+/11169
Autosubmit: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI
Reviewed-by: Profpatsch <mail@profpatsch.de>

users/Profpatsch/.hlint.yaml

@@ -129,7 +129,7 @@
       message: "`Data.Foldable.length` is dangerous to use, because it also works on types you wouldn’t expect, like `length (3,4) == 1` and `length (Just 2) == 1`. Use the `length` function for your specific type instead, for example `List.length` or `Map.length`."
 
     - name: Prelude.length
-      within: []
+      within: [MyPrelude]
       message: "`Prelude.length` is dangerous to use, because it also works on types you wouldn’t expect, like `length (3,4) == 1` and `length (Just 2) == 1`. Use the `length` function for your specific type instead, for example `List.length` or `Map.length`."
 
     # Using an explicit lambda with its argument “underscored”

users/Profpatsch/my-prelude/default.nix

@@ -28,6 +28,7 @@ pkgs.haskellPackages.mkDerivation {
     pkgs.haskellPackages.pa-pretty
     pkgs.haskellPackages.pa-field-parser
     pkgs.haskellPackages.aeson-better-errors
+    pkgs.haskellPackages.foldl
     pkgs.haskellPackages.resource-pool
     pkgs.haskellPackages.error
     pkgs.haskellPackages.hs-opentelemetry-api

users/Profpatsch/my-prelude/my-prelude.cabal

@@ -48,6 +48,8 @@ common common-options
     -- to enable the `type` keyword in import lists (ormolu uses this automatically)
     ExplicitNamespaces
 
+    -- allows defining pattern synonyms, but also the `import Foo (pattern FooPattern)` import syntax
+    PatternSynonyms
   default-language: GHC2021
 
 
@@ -83,6 +85,7 @@ library
      , aeson-better-errors
      , bytestring
      , containers
+     , foldl
      , unordered-containers
      , resource-pool
      , resourcet
@@ -101,9 +104,11 @@ library
      , PyF
      , semigroupoids
      , selective
+     , template-haskell
      , text
      , these
      , unix
      , unliftio
      , validation-selective
      , vector
+     , ghc-boot

users/Profpatsch/my-prelude/src/MyPrelude.hs

@@ -1,11 +1,7 @@
 {-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MagicHash #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fexpose-all-unfoldings #-}
 
 module MyPrelude
   ( -- * Text conversions
@@ -15,6 +11,7 @@ module MyPrelude
     fmt,
     textToString,
     stringToText,
+    stringToBytesUtf8,
     showToText,
     textToBytesUtf8,
     textToBytesUtf8Lazy,
@@ -42,6 +39,7 @@ module MyPrelude
     HasField,
 
     -- * Control flow
+    doAs,
     (&),
     (<&>),
     (<|>),
@@ -91,6 +89,9 @@ module MyPrelude
     failure,
     successes,
     failures,
+    traverseValidate,
+    traverseValidateM,
+    traverseValidateM_,
     eitherToValidation,
     eitherToListValidation,
     validationToEither,
@@ -100,15 +101,28 @@ module MyPrelude
     validationToThese,
     thenThese,
     thenValidate,
+    thenValidateM,
     NonEmpty ((:|)),
+    pattern IsEmpty,
+    pattern IsNonEmpty,
     singleton,
     nonEmpty,
     nonEmptyDef,
+    overNonEmpty,
+    zipNonEmpty,
+    zipWithNonEmpty,
+    zip3NonEmpty,
+    zipWith3NonEmpty,
+    zip4NonEmpty,
     toList,
-    toNonEmptyDefault,
+    lengthNatural,
     maximum1,
     minimum1,
+    maximumBy1,
+    minimumBy1,
+    Vector,
     Generic,
+    Lift,
     Semigroup,
     sconcat,
     Monoid,
@@ -120,6 +134,7 @@ module MyPrelude
     Identity (Identity, runIdentity),
     Natural,
     intToNatural,
+    Scientific,
     Contravariant,
     contramap,
     (>$<),
@@ -132,10 +147,16 @@ module MyPrelude
     Category,
     (>>>),
     (&>>),
+    Any,
 
     -- * Enum definition
     inverseFunction,
     inverseMap,
+    enumerateAll,
+
+    -- * Map helpers
+    mapFromListOn,
+    mapFromListOnMerge,
 
     -- * Error handling
     HasCallStack,
@@ -145,6 +166,7 @@ where
 
 import Control.Applicative ((<|>))
 import Control.Category (Category, (>>>))
+import Control.Foldl.NonEmpty qualified as Foldl1
 import Control.Monad (guard, join, unless, when)
 import Control.Monad.Catch (MonadThrow (throwM))
 import Control.Monad.Except
@@ -164,13 +186,15 @@ import Data.Char qualified
 import Data.Coerce (Coercible, coerce)
 import Data.Data (Proxy (Proxy))
 import Data.Error
-import Data.Foldable (Foldable (foldMap', toList), fold, foldl', for_, traverse_)
+import Data.Foldable (Foldable (foldMap', toList), fold, foldl', for_, sequenceA_, traverse_)
 import Data.Foldable qualified as Foldable
 import Data.Function ((&))
 import Data.Functor ((<&>))
 import Data.Functor.Contravariant (Contravariant (contramap), (>$<))
 import Data.Functor.Identity (Identity (runIdentity))
+import Data.List (zip4)
 import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)
+import Data.List.NonEmpty qualified as NonEmpty
 import Data.Map.Strict
   ( Map,
   )
@@ -178,7 +202,8 @@ import Data.Map.Strict qualified as Map
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Maybe qualified as Maybe
 import Data.Profunctor (Profunctor, dimap, lmap, rmap)
-import Data.Semigroup (Max (Max, getMax), Min (Min, getMin), sconcat)
+import Data.Scientific (Scientific)
+import Data.Semigroup (sconcat)
 import Data.Semigroup.Foldable (Foldable1 (fold1), foldMap1)
 import Data.Semigroup.Traversable (Traversable1)
 import Data.Semigroupoid (Semigroupoid (o))
@@ -192,14 +217,17 @@ import Data.Text.Lazy qualified
 import Data.Text.Lazy.Encoding qualified
 import Data.These (These (That, These, This))
 import Data.Traversable (for)
+import Data.Vector (Vector)
 import Data.Void (Void, absurd)
 import Data.Word (Word8)
 import GHC.Exception (errorCallWithCallStackException)
-import GHC.Exts (RuntimeRep, TYPE, raise#)
+import GHC.Exts (Any, RuntimeRep, TYPE, raise#)
 import GHC.Generics (Generic)
 import GHC.Natural (Natural)
 import GHC.Records (HasField)
 import GHC.Stack (HasCallStack)
+import GHC.Utils.Encoding qualified as GHC
+import Language.Haskell.TH.Syntax (Lift)
 import PyF (fmt)
 import System.Exit qualified
 import System.IO qualified
@@ -212,6 +240,21 @@ import Validation
     validationToEither,
   )
 
+-- | Mark a `do`-block with the type of the Monad/Applicativ it uses.
+-- Only intended for reading ease and making code easier to understand,
+-- especially do-blocks that use unconventional monads (like Maybe or List).
+--
+-- Example:
+--
+-- @
+-- doAs @Maybe $ do
+--  a <- Just 'a'
+--  b <- Just 'b'
+--  pure (a, b)
+-- @
+doAs :: forall m a. m a -> m a
+doAs = id
+
 -- | Forward-applying 'contramap', like '&'/'$' and '<&>'/'<$>' but for '>$<'.
 (>&<) :: (Contravariant f) => f b -> (a -> b) -> f a
 (>&<) = flip contramap
@@ -222,10 +265,10 @@ infixl 5 >&<
 --
 -- Specialized examples:
 --
--- @@
+-- @
 -- for functions : (a -> b) -> (b -> c) -> (a -> c)
 -- for Folds: Fold a b -> Fold b c -> Fold a c
--- @@
+-- @
 (&>>) :: (Semigroupoid s) => s a b -> s b c -> s a c
 (&>>) = flip Data.Semigroupoid.o
 
@@ -266,26 +309,51 @@ bytesToTextUtf8LenientLazy :: Data.ByteString.Lazy.ByteString -> Data.Text.Lazy.
 bytesToTextUtf8LenientLazy =
   Data.Text.Lazy.Encoding.decodeUtf8With Data.Text.Encoding.Error.lenientDecode
 
--- | Make a lazy text strict
+-- | Make a lazy 'Text' strict.
 toStrict :: Data.Text.Lazy.Text -> Text
 toStrict = Data.Text.Lazy.toStrict
 
--- | Make a strict text lazy
+-- | Make a strict 'Text' lazy.
 toLazy :: Text -> Data.Text.Lazy.Text
 toLazy = Data.Text.Lazy.fromStrict
 
+-- | Make a lazy 'ByteString' strict.
 toStrictBytes :: Data.ByteString.Lazy.ByteString -> ByteString
 toStrictBytes = Data.ByteString.Lazy.toStrict
 
+-- | Make a strict 'ByteString' lazy.
 toLazyBytes :: ByteString -> Data.ByteString.Lazy.ByteString
 toLazyBytes = Data.ByteString.Lazy.fromStrict
 
+-- | Convert a (performant) 'Text' into an (imperformant) list-of-char 'String'.
+--
+-- Some libraries (like @time@ or @network-uri@) still use the `String` as their interface. We only want to convert to string at the edges, otherwise use 'Text'.
+--
+-- ATTN: Don’t use `String` in code if you can avoid it, prefer `Text` instead.
 textToString :: Text -> String
 textToString = Data.Text.unpack
 
+-- | Convert an (imperformant) list-of-char 'String' into a (performant) 'Text' .
+--
+-- Some libraries (like @time@ or @network-uri@) still use the `String` as their interface. We want to convert 'String' to 'Text' as soon as possible and only use 'Text' in our code.
+--
+-- ATTN: Don’t use `String` in code if you can avoid it, prefer `Text` instead.
 stringToText :: String -> Text
 stringToText = Data.Text.pack
 
+-- | Encode a String to an UTF-8 encoded Bytestring
+--
+-- ATTN: Don’t use `String` in code if you can avoid it, prefer `Text` instead.
+stringToBytesUtf8 :: String -> ByteString
+stringToBytesUtf8 = GHC.utf8EncodeString
+
+-- | Like `show`, but generate a 'Text'
+--
+-- ATTN: This goes via `String` and thus is fairly inefficient.
+-- We should add a good display library at one point.
+--
+-- ATTN: unlike `show`, this forces the whole @'a
+-- so only use if you want to display the whole thing.
 showToText :: (Show a) => a -> Text
 showToText = stringToText . show
 
@@ -299,8 +367,20 @@ showToText = stringToText . show
 -- >>> charToWordUnsafe ','
 -- 44
 charToWordUnsafe :: Char -> Word8
-charToWordUnsafe = fromIntegral . Data.Char.ord
 {-# INLINE charToWordUnsafe #-}
+charToWordUnsafe = fromIntegral . Data.Char.ord
+
+pattern IsEmpty :: [a]
+pattern IsEmpty <- (null -> True)
+  where
+    IsEmpty = []
+
+pattern IsNonEmpty :: NonEmpty a -> [a]
+pattern IsNonEmpty n <- (nonEmpty -> Just n)
+  where
+    IsNonEmpty n = toList n
+
+{-# COMPLETE IsEmpty, IsNonEmpty #-}
 
 -- | Single element in a (non-empty) list.
 singleton :: a -> NonEmpty a
@@ -313,19 +393,69 @@ nonEmptyDef def xs =
     Nothing -> def :| []
     Just ne -> ne
 
--- | Construct a non-empty list, given a default value if the ist list was empty.
+-- | If the list is not empty, run the given function with a NonEmpty list, otherwise just return []
-toNonEmptyDefault :: a -> [a] -> NonEmpty a
+overNonEmpty :: (Applicative f) => (NonEmpty a -> f [b]) -> [a] -> f [b]
-toNonEmptyDefault def xs = case xs of
+overNonEmpty f xs = case xs of
-  [] -> def :| []
+  IsEmpty -> pure []
-  (x : xs') -> x :| xs'
+  IsNonEmpty xs' -> f xs'
 
--- | @O(n)@. Get the maximum element from a non-empty structure.
+-- | Zip two non-empty lists.
+zipNonEmpty :: NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
+{-# INLINE zipNonEmpty #-}
+zipNonEmpty ~(a :| as) ~(b :| bs) = (a, b) :| zip as bs
+
+-- | Zip two non-empty lists, combining them with the given function
+zipWithNonEmpty :: (a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
+{-# INLINE zipWithNonEmpty #-}
+zipWithNonEmpty = NonEmpty.zipWith
+
+-- | Zip three non-empty lists.
+zip3NonEmpty :: NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty (a, b, c)
+{-# INLINE zip3NonEmpty #-}
+zip3NonEmpty ~(a :| as) ~(b :| bs) ~(c :| cs) = (a, b, c) :| zip3 as bs cs
+
+-- | Zip three non-empty lists, combining them with the given function
+zipWith3NonEmpty :: (a -> b -> c -> d) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d
+{-# INLINE zipWith3NonEmpty #-}
+zipWith3NonEmpty f ~(x :| xs) ~(y :| ys) ~(z :| zs) = f x y z :| zipWith3 f xs ys zs
+
+-- | Zip four non-empty lists
+zip4NonEmpty :: NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d -> NonEmpty (a, b, c, d)
+{-# INLINE zip4NonEmpty #-}
+zip4NonEmpty ~(a :| as) ~(b :| bs) ~(c :| cs) ~(d :| ds) = (a, b, c, d) :| zip4 as bs cs ds
+
+-- | We don’t want to use Foldable’s `length`, because it is too polymorphic and can lead to bugs.
+-- Only list-y things should have a length.
+class (Foldable f) => Lengthy f
+
+instance Lengthy []
+
+instance Lengthy NonEmpty
+
+instance Lengthy Vector
+
+lengthNatural :: (Lengthy f) => f a -> Natural
+lengthNatural xs =
+  xs
+    & Foldable.length
+    -- length can never be negative or something went really, really wrong
+    & fromIntegral @Int @Natural
+
+-- | @O(n)@. Get the maximum element from a non-empty structure (strict).
 maximum1 :: (Foldable1 f, Ord a) => f a -> a
-maximum1 xs = xs & foldMap1 Max & getMax
+maximum1 = Foldl1.fold1 Foldl1.maximum
 
--- | @O(n)@. Get the minimum element from a non-empty structure.
+-- | @O(n)@. Get the maximum element from a non-empty structure, using the given comparator (strict).
+maximumBy1 :: (Foldable1 f) => (a -> a -> Ordering) -> f a -> a
+maximumBy1 f = Foldl1.fold1 (Foldl1.maximumBy f)
+
+-- | @O(n)@. Get the minimum element from a non-empty structure (strict).
 minimum1 :: (Foldable1 f, Ord a) => f a -> a
-minimum1 xs = xs & foldMap1 Min & getMin
+minimum1 = Foldl1.fold1 Foldl1.minimum
+
+-- | @O(n)@. Get the minimum element from a non-empty structure, using the given comparator (strict).
+minimumBy1 :: (Foldable1 f) => (a -> a -> Ordering) -> f a -> a
+minimumBy1 f = Foldl1.fold1 (Foldl1.minimumBy f)
 
 -- | Annotate a 'Maybe' with an error message and turn it into an 'Either'.
 annotate :: err -> Maybe a -> Either err a
@@ -355,8 +485,48 @@ findMaybe mPred list =
         Just a -> mPred a
         Nothing -> Nothing
 
+-- | 'traverse' with a function returning 'Either' and collect all errors that happen, if they happen.
+--
+-- Does not shortcut on error, so will always traverse the whole list/'Traversable' structure.
+--
+-- This is a useful error handling function in many circumstances,
+-- because it won’t only return the first error that happens, but rather all of them.
+traverseValidate :: forall t a err b. (Traversable t) => (a -> Either err b) -> t a -> Either (NonEmpty err) (t b)
+traverseValidate f as =
+  as
+    & traverse @t @(Validation _) (eitherToListValidation . f)
+    & validationToEither
+
+-- | 'traverse' with a function returning 'm Either' and collect all errors that happen, if they happen.
+--
+-- Does not shortcut on error, so will always traverse the whole list/'Traversable' structure.
+--
+-- This is a useful error handling function in many circumstances,
+-- because it won’t only return the first error that happens, but rather all of them.
+traverseValidateM :: forall t m a err b. (Traversable t, Applicative m) => (a -> m (Either err b)) -> t a -> m (Either (NonEmpty err) (t b))
+traverseValidateM f as =
+  as
+    & traverse @t @m (\a -> a & f <&> eitherToListValidation)
+    <&> sequenceA @t @(Validation _)
+    <&> validationToEither
+
+-- | 'traverse_' with a function returning 'm Either' and collect all errors that happen, if they happen.
+--
+-- Does not shortcut on error, so will always traverse the whole list/'Traversable' structure.
+--
+-- This is a useful error handling function in many circumstances,
+-- because it won’t only return the first error that happens, but rather all of them.
+traverseValidateM_ :: forall t m a err. (Traversable t, Applicative m) => (a -> m (Either err ())) -> t a -> m (Either (NonEmpty err) ())
+traverseValidateM_ f as =
+  as
+    & traverse @t @m (\a -> a & f <&> eitherToListValidation)
+    <&> sequenceA_ @t @(Validation _)
+    <&> validationToEither
+
 -- | Like 'eitherToValidation', but puts the Error side into a NonEmpty list
 -- to make it combine with other validations.
+--
+-- See also 'validateEithers', if you have a list of Either and want to collect all errors.
 eitherToListValidation :: Either a c -> Validation (NonEmpty a) c
 eitherToListValidation = first singleton . eitherToValidation
 
@@ -388,15 +558,26 @@ thenThese f x = do
   th <- x
   join <$> traverse f th
 
--- | Nested validating bind-like combinator inside some other @m@.
+-- | Nested validating bind-like combinator.
 --
 -- Use if you want to collect errors, and want to chain multiple functions returning 'Validation'.
 thenValidate ::
+  (a -> Validation err b) ->
+  Validation err a ->
+  Validation err b
+thenValidate f = \case
+  Success a -> f a
+  Failure err -> Failure err
+
+-- | Nested validating bind-like combinator inside some other @m@.
+--
+-- Use if you want to collect errors, and want to chain multiple functions returning 'Validation'.
+thenValidateM ::
   (Monad m) =>
   (a -> m (Validation err b)) ->
   m (Validation err a) ->
   m (Validation err b)
-thenValidate f x =
+thenValidateM f x =
   eitherToValidation <$> do
     x' <- validationToEither <$> x
     case x' of
@@ -429,23 +610,23 @@ exitWithMessage msg = do
 --
 -- … since @(Semigroup err => Validation err a)@ is a @Semigroup@/@Monoid@ itself.
 traverseFold :: (Applicative ap, Traversable t, Monoid m) => (a -> ap m) -> t a -> ap m
+{-# INLINE traverseFold #-}
 traverseFold f xs =
   -- note: could be weakened to (Foldable t) via `getAp . foldMap (Ap . f)`
   fold <$> traverse f xs
-{-# INLINE traverseFold #-}
 
 -- | Like 'traverseFold', but fold over a semigroup instead of a Monoid, by providing a starting element.
 traverseFoldDefault :: (Applicative ap, Traversable t, Semigroup m) => m -> (a -> ap m) -> t a -> ap m
+{-# INLINE traverseFoldDefault #-}
 traverseFoldDefault def f xs = foldDef def <$> traverse f xs
   where
     foldDef = foldr (<>)
-{-# INLINE traverseFoldDefault #-}
 
 -- | Same as 'traverseFold', but with a 'Semigroup' and 'Traversable1' restriction.
 traverseFold1 :: (Applicative ap, Traversable1 t, Semigroup s) => (a -> ap s) -> t a -> ap s
+{-# INLINE traverseFold1 #-}
 -- note: cannot be weakened to (Foldable1 t) because there is no `Ap` for Semigroup (No `Apply` typeclass)
 traverseFold1 f xs = fold1 <$> traverse f xs
-{-# INLINE traverseFold1 #-}
 
 -- | Use this in places where the code is still to be implemented.
 --
@@ -527,18 +708,31 @@ inverseFunction f k = Map.lookup k $ inverseMap f
 -- it returns a mapping from all possible outputs to their possible inputs.
 --
 -- This has the same restrictions of 'inverseFunction'.
-inverseMap ::
+inverseMap :: forall a k. (Bounded a, Enum a, Ord k) => (a -> k) -> Map k a
-  forall a k.
+inverseMap f = enumerateAll <&> (\a -> (f a, a)) & Map.fromList
-  (Bounded a, Enum a, Ord k) =>
+
-  (a -> k) ->
+-- | All possible values in this enum.
-  Map k a
+enumerateAll :: (Enum a, Bounded a) => [a]
-inverseMap f =
+enumerateAll = [minBound .. maxBound]
-  universe
+
-    <&> (\a -> (f a, a))
+-- | Create a 'Map' from a list of values, extracting the map key from each value. Like 'Map.fromList'.
-    & Map.fromList
+--
-  where
+-- Attention: if the key is not unique, the earliest value with the key will be in the map.
-    universe :: [a]
+mapFromListOn :: (Ord key) => (a -> key) -> [a] -> Map key a
-    universe = [minBound .. maxBound]
+mapFromListOn f xs = xs <&> (\x -> (f x, x)) & Map.fromList
+
+-- | Create a 'Map' from a list of values, merging multiple values at the same key with '<>' (left-to-right)
+--
+-- `f` has to extract the key and value. Value must be mergable.
+--
+-- Attention: if the key is not unique, the earliest value with the key will be in the map.
+mapFromListOnMerge :: (Ord key, Semigroup s) => (a -> (key, s)) -> [a] -> Map key s
+mapFromListOnMerge f xs =
+  xs
+    <&> (\x -> f x)
+    & Map.fromListWith
+      -- we have to flip (`<>`) because `Map.fromListWith` merges its values “the other way around”
+      (flip (<>))
 
 -- | If the predicate is true, return the @m@, else 'mempty'.
 --
@@ -570,12 +764,18 @@ ifTrue pred' m = if pred' then m else mempty
 -- >>> import Data.Monoid (Sum(..))
 --
 -- >>> :{ mconcat [
--- unknown command '{'
+--   ifExists (Just [1]),
+--   [2, 3, 4],
+--   ifExists Nothing,
+-- ]
+-- :}
+-- [1,2,3,4]
 --
 -- Or any other Monoid:
 --
--- >>> mconcat [ Sum 1, ifExists Sum (Just 2), Sum 3 ]
+-- >>> mconcat [ Sum 1, ifExists (Just (Sum 2)), Sum 3 ]
+
 -- Sum {getSum = 6}
 
-ifExists :: (Monoid m) => (a -> m) -> Maybe a -> m
+ifExists :: (Monoid m) => Maybe m -> m
-ifExists = foldMap
+ifExists = fold

users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs

@@ -1,14 +1,15 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Postgres.MonadPostgres where
 
 import AtLeast (AtLeast)
 import Control.Exception
+import Control.Foldl qualified as Fold
 import Control.Monad.Except
-import Control.Monad.Logger (MonadLogger, logDebug, logWarn)
+import Control.Monad.Logger.CallStack (MonadLogger, logDebug, logWarn)
 import Control.Monad.Reader (MonadReader (ask), ReaderT (..))
 import Control.Monad.Trans.Resource
 import Data.Aeson (FromJSON)
@@ -28,7 +29,7 @@ import Database.PostgreSQL.Simple.FromRow qualified as PG
 import Database.PostgreSQL.Simple.ToField (ToField)
 import Database.PostgreSQL.Simple.ToRow (ToRow (toRow))
 import Database.PostgreSQL.Simple.Types (Query (..))
-import GHC.Records (HasField (..))
+import GHC.Records (getField)
 import Label
 import OpenTelemetry.Trace.Core qualified as Otel hiding (inSpan, inSpan')
 import OpenTelemetry.Trace.Monad qualified as Otel
@@ -42,7 +43,7 @@ import Tool
 import UnliftIO (MonadUnliftIO (withRunInIO))
 import UnliftIO.Process qualified as Process
 import UnliftIO.Resource qualified as Resource
-import Prelude hiding (span)
+import Prelude hiding (init, span)
 
 -- | Postgres queries/commands that can be executed within a running transaction.
 --
@@ -52,28 +53,46 @@ class (Monad m) => MonadPostgres (m :: Type -> Type) where
   -- | Execute an INSERT, UPDATE, or other SQL query that is not expected to return results.
 
   -- Returns the number of rows affected.
-  execute :: (ToRow params, Typeable params) => Query -> params -> Transaction m (Label "numberOfRowsAffected" Natural)
+  execute ::
-
+    (ToRow params, Typeable params) =>
-  -- | Execute an INSERT, UPDATE, or other SQL query that is not expected to return results. Does not take parameters.
+    Query ->
-
+    params ->
-  -- Returns the number of rows affected.
+    Transaction m (Label "numberOfRowsAffected" Natural)
-  execute_ :: Query -> Transaction m (Label "numberOfRowsAffected" Natural)
 
   -- | Execute a multi-row INSERT, UPDATE, or other SQL query that is not expected to return results.
   --
-  -- Returns the number of rows affected. If the list of parameters is empty, this function will simply return 0 without issuing the query to the backend. If this is not desired, consider using the 'PG.Values' constructor instead.
+  -- Returns the number of rows affected. If the list of parameters is empty,
-  executeMany :: (ToRow params, Typeable params) => Query -> [params] -> Transaction m (Label "numberOfRowsAffected" Natural)
+  -- this function will simply return 0 without issuing the query to the backend.
+  -- If this is not desired, consider using the 'PG.Values' constructor instead.
+  executeMany ::
+    (ToRow params, Typeable params) =>
+    Query ->
+    NonEmpty params ->
+    Transaction m (Label "numberOfRowsAffected" Natural)
 
-  -- | Execute INSERT ... RETURNING, UPDATE ... RETURNING, or other SQL query that accepts multi-row input and is expected to return results. Note that it is possible to write query conn "INSERT ... RETURNING ..." ... in cases where you are only inserting a single row, and do not need functionality analogous to 'executeMany'.
+  -- | Execute INSERT ... RETURNING, UPDATE ... RETURNING,
+  -- or other SQL query that accepts multi-row input and is expected to return results.
+  -- Note that it is possible to write query conn "INSERT ... RETURNING ..." ...
+  -- in cases where you are only inserting a single row,
+  -- and do not need functionality analogous to 'executeMany'.
   --
   -- If the list of parameters is empty, this function will simply return [] without issuing the query to the backend. If this is not desired, consider using the 'PG.Values' constructor instead.
-  executeManyReturningWith :: (ToRow q) => Query -> [q] -> Decoder r -> Transaction m [r]
+  executeManyReturningWith :: (ToRow q) => Query -> NonEmpty q -> Decoder r -> Transaction m [r]
 
   -- | Run a query, passing parameters and result row parser.
-  queryWith :: (PG.ToRow params, Typeable params, Typeable r) => PG.Query -> params -> Decoder r -> Transaction m [r]
+  queryWith ::
+    (PG.ToRow params, Typeable params, Typeable r) =>
+    PG.Query ->
+    params ->
+    Decoder r ->
+    Transaction m [r]
 
   -- | Run a query without any parameters and result row parser.
-  queryWith_ :: (Typeable r) => PG.Query -> Decoder r -> Transaction m [r]
+  queryWith_ ::
+    (Typeable r) =>
+    PG.Query ->
+    Decoder r ->
+    Transaction m [r]
 
   -- | Run a query, passing parameters, and fold over the resulting rows.
   --
@@ -82,13 +101,15 @@ class (Monad m) => MonadPostgres (m :: Type -> Type) where
   --
   -- When dealing with small results, it may be simpler (and perhaps faster) to use query instead.
   --
-  -- This fold is _not_ strict. The stream consumer is responsible for forcing the evaluation of its result to avoid space leaks.
+  -- This fold is _not_ strict. The stream consumer is responsible
+  -- for forcing the evaluation of its result to avoid space leaks.
   --
   -- If you can, prefer aggregating in the database itself.
-  foldRows ::
+  foldRowsWithAcc ::
-    (FromRow row, ToRow params, Typeable row, Typeable params) =>
+    (ToRow params, Typeable row, Typeable params) =>
     Query ->
     params ->
+    Decoder row ->
     a ->
     (a -> row -> Transaction m a) ->
     Transaction m a
@@ -109,12 +130,23 @@ class (Monad m) => MonadPostgres (m :: Type -> Type) where
   -- Only handlers should run transactions.
   runTransaction :: Transaction m a -> m a
 
--- | Run a query, passing parameters.
+-- | Run a query, passing parameters. Prefer 'queryWith' if possible.
-query :: forall m params r. (PG.ToRow params, PG.FromRow r, Typeable params, Typeable r, MonadPostgres m) => PG.Query -> params -> Transaction m [r]
+query ::
+  forall m params r.
+  (PG.ToRow params, PG.FromRow r, Typeable params, Typeable r, MonadPostgres m) =>
+  PG.Query ->
+  params ->
+  Transaction m [r]
 query qry params = queryWith qry params (Decoder PG.fromRow)
 
--- | Run a query without any parameters.
+-- | Run a query without any parameters. Prefer 'queryWith' if possible.
-query_ :: forall m r. (Typeable r, PG.FromRow r, MonadPostgres m) => PG.Query -> Transaction m [r]
+--
+-- TODO: I think(?) this can always be replaced by passing @()@ to 'query', remove?
+query_ ::
+  forall m r.
+  (Typeable r, PG.FromRow r, MonadPostgres m) =>
+  PG.Query ->
+  Transaction m [r]
 query_ qry = queryWith_ qry (Decoder PG.fromRow)
 
 -- TODO: implement via fold, so that the result doesn’t have to be realized in memory
@@ -153,7 +185,10 @@ querySingleRowMaybe qry params = do
     -- that a database function can error out, should probably handled by the instances.
     more -> throwM $ SingleRowError {numberOfRowsReturned = (List.length more)}
 
-ensureSingleRow :: (MonadThrow m) => [a] -> m a
+ensureSingleRow ::
+  (MonadThrow m) =>
+  [a] ->
+  m a
 ensureSingleRow = \case
   -- TODO: Should we MonadThrow this here? It’s really an implementation detail of MonadPostgres
   -- that a database function can error out, should probably handled by the instances.
@@ -167,6 +202,52 @@ ensureSingleRow = \case
             List.length more
         }
 
+ensureNoneOrSingleRow ::
+  (MonadThrow m) =>
+  [a] ->
+  m (Maybe a)
+ensureNoneOrSingleRow = \case
+  -- TODO: Should we MonadThrow this here? It’s really an implementation detail of MonadPostgres
+  -- that a database function can error out, should probably handled by the instances.
+  [] -> pure Nothing
+  [one] -> pure $ Just one
+  more ->
+    throwM $
+      SingleRowError
+        { numberOfRowsReturned =
+            -- TODO: this is VERY bad, because it requires to parse the full database output, even if there’s 10000000000 elements
+            List.length more
+        }
+
+-- | Run a query, passing parameters, and fold over the resulting rows.
+--
+-- This doesn’t have to realize the full list of results in memory,
+-- rather results are streamed incrementally from the database.
+--
+-- When dealing with small results, it may be simpler (and perhaps faster) to use query instead.
+--
+-- The results are folded strictly by the 'Fold.Fold' that is passed.
+--
+-- If you can, prefer aggregating in the database itself.
+foldRowsWith ::
+  forall row params m b.
+  ( MonadPostgres m,
+    PG.ToRow params,
+    Typeable row,
+    Typeable params
+  ) =>
+  PG.Query ->
+  params ->
+  Decoder row ->
+  Fold.Fold row b ->
+  Transaction m b
+foldRowsWith qry params decoder = Fold.purely f
+  where
+    f :: forall x. (x -> row -> x) -> x -> (x -> b) -> Transaction m b
+    f acc init extract = do
+      x <- foldRowsWithAcc qry params decoder init (\a r -> pure $ acc a r)
+      pure $ extract x
+
 newtype Transaction m a = Transaction {unTransaction :: (ReaderT Connection m a)}
   deriving newtype
     ( Functor,
@@ -180,9 +261,6 @@ newtype Transaction m a = Transaction {unTransaction :: (ReaderT Connection m a)
       Otel.MonadTracer
     )
 
-runTransaction' :: Connection -> Transaction m a -> m a
-runTransaction' conn transaction = runReaderT transaction.unTransaction conn
-
 -- | [Resource Pool](http://hackage.haskell.org/package/resource-pool-0.2.3.2/docs/Data-Pool.html) configuration.
 data PoolingInfo = PoolingInfo
   { -- | Minimal amount of resources that are
@@ -237,17 +315,41 @@ initMonadPostgres logInfoFn connectInfo poolingInfo = do
       IO ()
     destroyPGConnPool p = Pool.destroyAllResources p
 
+-- | Improve a possible error message, by adding some context to it.
+--
+-- The given Exception type is caught, 'show'n and pretty-printed.
+--
+-- In case we get an `IOError`, we display it in a reasonable fashion.
+addErrorInformation ::
+  forall exc a.
+  (Exception exc) =>
+  Text.Text ->
+  IO a ->
+  IO a
+addErrorInformation msg io =
+  io
+    & try @exc
+    <&> first (showPretty >>> newError >>> errorContext msg)
+    & try @IOError
+    <&> first (showToError >>> errorContext "IOError" >>> errorContext msg)
+    <&> join @(Either Error)
+    >>= unwrapIOError
+
 -- | Catch any Postgres exception that gets thrown,
 -- print the query that was run and the query parameters,
 -- then rethrow inside an 'Error'.
 handlePGException ::
   forall a params tools m.
-  (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool) =>
+  ( ToRow params,
+    MonadUnliftIO m,
+    MonadLogger m,
+    HasField "pgFormat" tools Tool
+  ) =>
   tools ->
   Text ->
   Query ->
   -- | Depending on whether we used `format` or `formatMany`.
-  Either params [params] ->
+  Either params (NonEmpty params) ->
   IO a ->
   Transaction m a
 handlePGException tools queryType query' params io = do
@@ -289,7 +391,11 @@ withPGTransaction connPool f =
     connPool
     (\conn -> Postgres.withTransaction conn (f conn))
 
-runPGTransactionImpl :: (MonadUnliftIO m) => m (Pool Postgres.Connection) -> Transaction m a -> m a
+runPGTransactionImpl ::
+  (MonadUnliftIO m) =>
+  m (Pool Postgres.Connection) ->
+  Transaction m a ->
+  m a
 {-# INLINE runPGTransactionImpl #-}
 runPGTransactionImpl zoom (Transaction transaction) = do
   pool <- zoom
@@ -337,7 +443,7 @@ executeManyImpl ::
   m tools ->
   m DebugLogDatabaseQueries ->
   Query ->
-  [params] ->
+  NonEmpty params ->
   Transaction m (Label "numberOfRowsAffected" Natural)
 executeManyImpl zoomTools zoomDebugLogDatabaseQueries qry params =
   Otel.inSpan' "Postgres Query (execute)" Otel.defaultSpanArguments $ \span -> do
@@ -345,7 +451,7 @@ executeManyImpl zoomTools zoomDebugLogDatabaseQueries qry params =
     logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
     traceQueryIfEnabled tools span logDatabaseQueries qry (HasMultiParams params)
     conn <- Transaction ask
-    PG.executeMany conn qry params
+    PG.executeMany conn qry (params & toList)
       & handlePGException tools "executeMany" qry (Right params)
       >>= toNumberOfRowsAffected "executeManyImpl"
 
@@ -364,7 +470,7 @@ executeManyReturningWithImpl ::
   m tools ->
   m DebugLogDatabaseQueries ->
   Query ->
-  [params] ->
+  NonEmpty params ->
   Decoder r ->
   Transaction m [r]
 {-# INLINE executeManyReturningWithImpl #-}
@@ -374,33 +480,45 @@ executeManyReturningWithImpl zoomTools zoomDebugLogDatabaseQueries qry params (D
     logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
     traceQueryIfEnabled tools span logDatabaseQueries qry (HasMultiParams params)
     conn <- Transaction ask
-    PG.returningWith fromRow conn qry params
+    PG.returningWith fromRow conn qry (params & toList)
       & handlePGException tools "executeManyReturning" qry (Right params)
 
-foldRowsImpl ::
+foldRowsWithAccImpl ::
-  (FromRow row, ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool) =>
+  ( ToRow params,
+    MonadUnliftIO m,
+    MonadLogger m,
+    HasField "pgFormat" tools Tool,
+    Otel.MonadTracer m
+  ) =>
   m tools ->
+  m DebugLogDatabaseQueries ->
   Query ->
   params ->
+  Decoder row ->
   a ->
   (a -> row -> Transaction m a) ->
   Transaction m a
-{-# INLINE foldRowsImpl #-}
+{-# INLINE foldRowsWithAccImpl #-}
-foldRowsImpl zoomTools qry params accumulator f = do
+foldRowsWithAccImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder rowParser) accumulator f = do
-  conn <- Transaction ask
+  Otel.inSpan' "Postgres Query (foldRowsWithAcc)" Otel.defaultSpanArguments $ \span -> do
-  tools <- lift @Transaction zoomTools
+    tools <- lift @Transaction zoomTools
-  withRunInIO
+    logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
-    ( \runInIO ->
+    traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params)
-        do
+    conn <- Transaction ask
-          PG.fold
+    withRunInIO
-            conn
+      ( \runInIO ->
-            qry
+          do
-            params
+            PG.foldWithOptionsAndParser
-            accumulator
+              PG.defaultFoldOptions
-            (\acc row -> runInIO $ f acc row)
+              rowParser
-            & handlePGException tools "fold" qry (Left params)
+              conn
-            & runInIO
+              qry
-    )
+              params
+              accumulator
+              (\acc row -> runInIO $ f acc row)
+              & handlePGException tools "fold" qry (Left params)
+              & runInIO
+      )
 
 pgFormatQueryNoParams' ::
   (MonadIO m, MonadLogger m, HasField "pgFormat" tools Tool) =>
@@ -410,18 +528,38 @@ pgFormatQueryNoParams' ::
 pgFormatQueryNoParams' tools q =
   lift $ pgFormatQueryByteString tools q.fromQuery
 
-pgFormatQuery :: (ToRow params, MonadIO m) => Query -> params -> Transaction m ByteString
+pgFormatQuery ::
+  (ToRow params, MonadIO m) =>
+  Query ->
+  params ->
+  Transaction m ByteString
 pgFormatQuery qry params = Transaction $ do
   conn <- ask
   liftIO $ PG.formatQuery conn qry params
 
-pgFormatQueryMany :: (MonadIO m, ToRow params) => Query -> [params] -> Transaction m ByteString
+pgFormatQueryMany ::
+  (MonadIO m, ToRow params) =>
+  Query ->
+  NonEmpty params ->
+  Transaction m ByteString
 pgFormatQueryMany qry params = Transaction $ do
   conn <- ask
-  liftIO $ PG.formatMany conn qry params
+  liftIO $
+    PG.formatMany
+      conn
+      qry
+      ( params
+          -- upstream is partial on empty list, see https://github.com/haskellari/postgresql-simple/issues/129
+          & toList
+      )
 
 queryWithImpl ::
-  (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool, Otel.MonadTracer m) =>
+  ( ToRow params,
+    MonadUnliftIO m,
+    MonadLogger m,
+    HasField "pgFormat" tools Tool,
+    Otel.MonadTracer m
+  ) =>
   m tools ->
   m DebugLogDatabaseQueries ->
   Query ->
@@ -438,7 +576,15 @@ queryWithImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder fromRow)
     PG.queryWith fromRow conn qry params
       & handlePGException tools "query" qry (Left params)
 
-queryWithImpl_ :: (MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool) => m tools -> Query -> Decoder r -> Transaction m [r]
+queryWithImpl_ ::
+  ( MonadUnliftIO m,
+    MonadLogger m,
+    HasField "pgFormat" tools Tool
+  ) =>
+  m tools ->
+  Query ->
+  Decoder r ->
+  Transaction m [r]
 {-# INLINE queryWithImpl_ #-}
 queryWithImpl_ zoomTools qry (Decoder fromRow) = do
   tools <- lift @Transaction zoomTools
@@ -446,18 +592,6 @@ queryWithImpl_ zoomTools qry (Decoder fromRow) = do
   liftIO (PG.queryWith_ fromRow conn qry)
     & handlePGException tools "query" qry (Left ())
 
-pgQuery :: (ToRow params, FromRow r, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool) => tools -> Query -> params -> Transaction m [r]
-pgQuery tools qry params = do
-  conn <- Transaction ask
-  PG.query conn qry params
-    & handlePGException tools "query" qry (Left params)
-
-pgQuery_ :: (FromRow r, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools Tool) => tools -> Query -> Transaction m [r]
-pgQuery_ tools qry = do
-  conn <- Transaction ask
-  PG.query_ conn qry
-    & handlePGException tools "query_" qry (Left ())
-
 data SingleRowError = SingleRowError
   { -- | How many columns were actually returned by the query
     numberOfRowsReturned :: Int
@@ -467,12 +601,30 @@ data SingleRowError = SingleRowError
 instance Exception SingleRowError where
   displayException (SingleRowError {..}) = [fmt|Single row expected from SQL query result, {numberOfRowsReturned} rows were returned instead."|]
 
-pgFormatQuery' :: (MonadIO m, ToRow params, MonadLogger m, HasField "pgFormat" tools Tool) => tools -> Query -> params -> Transaction m Text
+pgFormatQuery' ::
+  ( MonadIO m,
+    ToRow params,
+    MonadLogger m,
+    HasField "pgFormat" tools Tool
+  ) =>
+  tools ->
+  Query ->
+  params ->
+  Transaction m Text
 pgFormatQuery' tools q p =
   pgFormatQuery q p
     >>= lift . pgFormatQueryByteString tools
 
-pgFormatQueryMany' :: (MonadIO m, ToRow params, MonadLogger m, HasField "pgFormat" tools Tool) => tools -> Query -> [params] -> Transaction m Text
+pgFormatQueryMany' ::
+  ( MonadIO m,
+    ToRow params,
+    MonadLogger m,
+    HasField "pgFormat" tools Tool
+  ) =>
+  tools ->
+  Query ->
+  NonEmpty params ->
+  Transaction m Text
 pgFormatQueryMany' tools q p =
   pgFormatQueryMany q p
     >>= lift . pgFormatQueryByteString tools
@@ -481,7 +633,14 @@ pgFormatQueryMany' tools q p =
 postgresToolsParser :: ToolParserT IO (Label "pgFormat" Tool)
 postgresToolsParser = label @"pgFormat" <$> readTool "pg_format"
 
-pgFormatQueryByteString :: (MonadIO m, MonadLogger m, HasField "pgFormat" tools Tool) => tools -> ByteString -> m Text
+pgFormatQueryByteString ::
+  ( MonadIO m,
+    MonadLogger m,
+    HasField "pgFormat" tools Tool
+  ) =>
+  tools ->
+  ByteString ->
+  m Text
 pgFormatQueryByteString tools queryBytes = do
   do
     (exitCode, stdout, stderr) <-
@@ -492,8 +651,8 @@ pgFormatQueryByteString tools queryBytes = do
     case exitCode of
       ExitSuccess -> pure (stdout & stringToText)
       ExitFailure status -> do
-        $logWarn [fmt|pg_format failed with status {status} while formatting the query, using original query string. Is there a syntax error?|]
+        logWarn [fmt|pg_format failed with status {status} while formatting the query, using original query string. Is there a syntax error?|]
-        $logDebug
+        logDebug
           ( prettyErrorTree
               ( nestedMultiError
                   "pg_format output"
@@ -502,7 +661,7 @@ pgFormatQueryByteString tools queryBytes = do
                   )
               )
           )
-        $logDebug [fmt|pg_format stdout: stderr|]
+        logDebug [fmt|pg_format stdout: stderr|]
         pure (queryBytes & bytesToTextUtf8Lenient)
 
 data DebugLogDatabaseQueries
@@ -517,7 +676,7 @@ data DebugLogDatabaseQueries
 data HasQueryParams param
   = HasNoParams
   | HasSingleParam param
-  | HasMultiParams [param]
+  | HasMultiParams (NonEmpty param)
 
 -- | Log the postgres query depending on the given setting
 traceQueryIfEnabled ::

users/Profpatsch/whatcd-resolver/src/AppT.hs

@@ -119,12 +119,12 @@ recordException span dat = liftIO $ do
 
 instance (MonadThrow m, MonadUnliftIO m) => MonadPostgres (AppT m) where
   execute = executeImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
-  execute_ = executeImpl_ (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
   executeMany = executeManyImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
   executeManyReturningWith = executeManyReturningWithImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
   queryWith = queryWithImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
   queryWith_ = queryWithImpl_ (AppT ask)
-  foldRows = foldRowsImpl (AppT ask)
+
+  foldRowsWithAcc = foldRowsWithAccImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
   runTransaction = runPGTransaction
 
 runPGTransaction :: (MonadUnliftIO m) => Transaction (AppT m) a -> AppT m a

users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs

@@ -35,6 +35,7 @@ import Json.Enc (Enc)
 import Json.Enc qualified as Enc
 import Label
 import Multipart2 qualified as Multipart
+import MyPrelude
 import Network.HTTP.Client.Conduit qualified as Http
 import Network.HTTP.Simple qualified as Http
 import Network.HTTP.Types
@@ -50,7 +51,6 @@ import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan')
 import OpenTelemetry.Trace.Monad qualified as Otel
 import Parse (Parse)
 import Parse qualified
-import PossehlAnalyticsPrelude
 import Postgres.Decoder qualified as Dec
 import Postgres.MonadPostgres
 import Pretty
@@ -848,7 +848,9 @@ redactedSearchAndInsert extraArguments = do
   pure $
     (firstPage : otherPages)
       & concatMap (.tourGroups)
-      & insertTourGroupsAndTorrents
+      & \case
+        IsNonEmpty tgs -> tgs & insertTourGroupsAndTorrents
+        IsEmpty -> pure ()
   where
     go mpage =
       redactedSearch
@@ -893,12 +895,13 @@ redactedSearchAndInsert extraArguments = do
                   )
         )
     insertTourGroupsAndTorrents ::
-      [ T2
+      NonEmpty
-          "tourGroup"
+        ( T2
-          (T3 "groupId" Int "groupName" Text "fullJsonResult" Json.Value)
+            "tourGroup"
-          "torrents"
+            (T3 "groupId" Int "groupName" Text "fullJsonResult" Json.Value)
-          [T2 "torrentId" Int "fullJsonResult" Json.Value]
+            "torrents"
-      ] ->
+            [T2 "torrentId" Int "fullJsonResult" Json.Value]
+        ) ->
       Transaction m ()
     insertTourGroupsAndTorrents dat = do
       let tourGroups = dat <&> (.tourGroup)
@@ -909,23 +912,22 @@ redactedSearchAndInsert extraArguments = do
                   zipT2 $
                     T2
                       (label @"torrentGroupIdPg" $ res <&> (.tourGroupIdPg))
-                      (label @"torrents" torrents)
+                      (label @"torrents" (torrents & toList))
             )
     insertTourGroups ::
-      [ T3
+      NonEmpty
-          "groupId"
+        ( T3
-          Int
+            "groupId"
-          "groupName"
+            Int
-          Text
+            "groupName"
-          "fullJsonResult"
+            Text
-          Json.Value
+            "fullJsonResult"
-      ] ->
+            Json.Value
+        ) ->
       Transaction m [Label "tourGroupIdPg" Int]
     insertTourGroups dats = do
       let groupNames =
-            [ [fmt|{dat.groupId}: {dat.groupName}|]
+            dats <&> \dat -> [fmt|{dat.groupId}: {dat.groupName}|]
-              | dat <- dats
-            ]
       logInfo [fmt|Inserting tour groups for {showPretty groupNames}|]
       _ <-
         execute
@@ -933,7 +935,7 @@ redactedSearchAndInsert extraArguments = do
                   DELETE FROM redacted.torrent_groups
                   WHERE group_id = ANY (?::integer[])
               |]
-          (Only $ (dats <&> (.groupId) & PGArray :: PGArray Int))
+          (Only $ (dats <&> (.groupId) & toList & PGArray :: PGArray Int))
       executeManyReturningWith
         [fmt|
               INSERT INTO redacted.torrent_groups (
@@ -1082,7 +1084,7 @@ migrate ::
   ) =>
   Transaction m (Label "numberOfRowsAffected" Natural)
 migrate = inSpan "Database Migration" $ do
-  execute_
+  execute
     [sql|
     CREATE SCHEMA IF NOT EXISTS redacted;
 
@@ -1134,6 +1136,7 @@ migrate = inSpan "Database Migration" $ do
     CREATE INDEX IF NOT EXISTS torrents_json_seeding ON redacted.torrents_json(((full_json_result->'seeding')::integer));
     CREATE INDEX IF NOT EXISTS torrents_json_snatches ON redacted.torrents_json(((full_json_result->'snatches')::integer));
   |]
+    ()
 
 data TorrentData transmissionInfo = TorrentData
   { groupId :: Int,