about summary refs log tree commit diff
path: root/users/Profpatsch/my-prelude
diff options
context:
space:
mode:
Diffstat (limited to 'users/Profpatsch/my-prelude')
-rw-r--r--users/Profpatsch/my-prelude/default.nix2
-rw-r--r--users/Profpatsch/my-prelude/my-prelude.cabal3
-rw-r--r--users/Profpatsch/my-prelude/src/Json.hs258
-rw-r--r--users/Profpatsch/my-prelude/src/Json/Enc.hs272
-rw-r--r--users/Profpatsch/my-prelude/src/Postgres/Decoder.hs63
-rw-r--r--users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs276
-rw-r--r--users/Profpatsch/my-prelude/src/Pretty.hs15
7 files changed, 783 insertions, 106 deletions
diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix
index 4bca8ea49f6f..a851fdcb0a5f 100644
--- a/users/Profpatsch/my-prelude/default.nix
+++ b/users/Profpatsch/my-prelude/default.nix
@@ -7,6 +7,8 @@ pkgs.haskellPackages.mkDerivation {
   src = depot.users.Profpatsch.exactSource ./. [
     ./my-prelude.cabal
     ./src/Aeson.hs
+    ./src/Json.hs
+    ./src/Json/Enc.hs
     ./src/Arg.hs
     ./src/AtLeast.hs
     ./src/MyPrelude.hs
diff --git a/users/Profpatsch/my-prelude/my-prelude.cabal b/users/Profpatsch/my-prelude/my-prelude.cabal
index 2f7882a526ae..ba64f1c3fc27 100644
--- a/users/Profpatsch/my-prelude/my-prelude.cabal
+++ b/users/Profpatsch/my-prelude/my-prelude.cabal
@@ -61,6 +61,8 @@ library
       Aeson
       Arg
       AtLeast
+      Json
+      Json.Enc
       Test
       Postgres.Decoder
       Postgres.MonadPostgres
@@ -85,6 +87,7 @@ library
      , pa-field-parser
      , aeson
      , aeson-better-errors
+     , base64-bytestring
      , bytestring
      , containers
      , foldl
diff --git a/users/Profpatsch/my-prelude/src/Json.hs b/users/Profpatsch/my-prelude/src/Json.hs
new file mode 100644
index 000000000000..3738ec6adfff
--- /dev/null
+++ b/users/Profpatsch/my-prelude/src/Json.hs
@@ -0,0 +1,258 @@
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Json where
+
+import Data.Aeson (FromJSON (parseJSON), ToJSON (toEncoding, toJSON), Value (..), withObject)
+import Data.Aeson qualified as Json
+import Data.Aeson.BetterErrors qualified as Json
+import Data.Aeson.Types qualified
+import Data.Error.Tree
+import Data.Map.Strict qualified as Map
+import Data.Maybe (catMaybes)
+import Data.Set (Set)
+import Data.Set qualified as Set
+import Data.Text qualified as Text
+import Data.Time (UTCTime)
+import Data.Vector qualified as Vector
+import FieldParser (FieldParser)
+import FieldParser qualified as Field
+import Label
+import PossehlAnalyticsPrelude
+
+-- | Use a "Data.Aeson.BetterErrors" parser to implement 'FromJSON'’s 'parseJSON' method.
+--
+-- @
+-- instance FromJSON Foo where
+--   parseJSON = Json.toParseJSON parseFoo
+-- @
+toParseJSON ::
+  -- | the error type is 'Error', if you need 'ErrorTree' use 'toParseJSONErrorTree'
+  Json.Parse Error a ->
+  Value ->
+  Data.Aeson.Types.Parser a
+toParseJSON = Json.toAesonParser prettyError
+
+-- | Use a "Data.Aeson.BetterErrors" parser to implement 'FromJSON'’s 'parseJSON' method.
+--
+-- @
+-- instance FromJSON Foo where
+--   parseJSON = Json.toParseJSON parseFoo
+-- @
+toParseJSONErrorTree ::
+  -- | the error type is 'ErrorTree', if you need 'Error' use 'toParseJSON'
+  Json.Parse ErrorTree a ->
+  Value ->
+  Data.Aeson.Types.Parser a
+toParseJSONErrorTree = Json.toAesonParser prettyErrorTree
+
+-- | Convert a 'Json.ParseError' to a corresponding 'ErrorTree'
+--
+-- TODO: build a different version of 'Json.displayError' so that we can nest 'ErrorTree' as well
+parseErrorTree :: Error -> Json.ParseError ErrorTree -> ErrorTree
+parseErrorTree contextMsg errs =
+  errs
+    & Json.displayError prettyErrorTree
+    & Text.intercalate "\n"
+    & newError
+    -- We nest this here because the json errors is multiline, so the result looks like
+    --
+    -- @
+    -- contextMsg
+    -- \|
+    -- `- At the path: ["foo"]["bar"]
+    --   Type mismatch:
+    --   Expected a value of type object
+    --   Got: true
+    -- @
+    & singleError
+    & nestedError contextMsg
+
+-- | Lift the parser error to an error tree
+asErrorTree :: (Functor m) => Json.ParseT Error m a -> Json.ParseT ErrorTree m a
+asErrorTree = Json.mapError singleError
+
+-- | Parse the json array into a 'Set'.
+asArraySet ::
+  (Ord a, Monad m) =>
+  Json.ParseT err m a ->
+  Json.ParseT err m (Set a)
+asArraySet inner = Set.fromList <$> Json.eachInArray inner
+
+-- | Parse the json object into a 'Map'.
+asObjectMap ::
+  (Monad m) =>
+  Json.ParseT err m a ->
+  Json.ParseT err m (Map Text a)
+asObjectMap inner = Map.fromList <$> Json.eachInObject inner
+
+-- | Parse as json array and count the number of elements in the array.
+countArrayElements :: (Monad m) => Json.ParseT Error m Natural
+countArrayElements = Field.toJsonParser ((jsonArray <&> Vector.length) >>> Field.integralToNatural)
+  where
+    -- I don’t want to add this to the FieldParser module, cause users should not be dealing with arrays manually.
+    jsonArray :: FieldParser Json.Value (Vector Json.Value)
+    jsonArray = Field.FieldParser $ \case
+      Json.Array vec -> Right vec
+      _ -> Left "Not a json array"
+
+-- | Parse as json number and convert it to a 'Double'. Throws an error if the number does not fit into a 'Double'.
+asDouble :: (Monad m) => Json.ParseT Error m Double
+asDouble =
+  Field.toJsonParser
+    ( Field.jsonNumber
+        >>> Field.boundedScientificRealFloat @Double
+    )
+
+asInt :: (Monad m) => Json.ParseT Error m Int
+asInt =
+  Field.toJsonParser
+    ( Field.jsonNumber
+        >>> Field.boundedScientificIntegral @Int "Cannot parse into Int"
+    )
+
+-- | Json string containing a UTC timestamp,
+-- @yyyy-mm-ddThh:mm:ss[.sss]Z@ (ISO 8601:2004(E) sec. 4.3.2 extended format)
+asUtcTime :: (Monad m) => Json.ParseT Error m UTCTime
+asUtcTime = Field.toJsonParser (Field.jsonString >>> Field.utcTime)
+
+-- | Json string containing a UTC timestamp.
+-- | Accepts multiple timezone formats.
+-- Do not use this if you can force the input to use the `Z` UTC notation (e.g. in a CSV), use 'utcTime' instead.
+--
+-- Accepts
+--
+-- * UTC timestamps: @yyyy-mm-ddThh:mm:ss[.sss]Z@
+-- * timestamps with time zone: @yyyy-mm-ddThh:mm:ss[.sss]±hh:mm@
+--
+-- ( both ISO 8601:2004(E) sec. 4.3.2 extended format)
+--
+-- The time zone of the second kind of timestamp is taken into account, but normalized to UTC (it’s not preserved what the original time zone was)
+asUtcTimeLenient :: (Monad m) => Json.ParseT Error m UTCTime
+asUtcTimeLenient = Field.toJsonParser (Field.jsonString >>> Field.utcTimeLenient)
+
+-- | Parse a key from the object, à la 'Json.key', return a labelled value.
+--
+-- We don’t provide a version that infers the json object key,
+-- since that conflates internal naming with the external API, which is dangerous.
+--
+-- @@
+-- do
+--   txt <- keyLabel @"myLabel" "jsonKeyName" Json.asText
+--   pure (txt :: Label "myLabel" Text)
+-- @@
+keyLabel ::
+  forall label err m a.
+  (Monad m) =>
+  Text ->
+  Json.ParseT err m a ->
+  Json.ParseT err m (Label label a)
+keyLabel = do
+  keyLabel' (Proxy @label)
+
+-- | Parse a key from the object, à la 'Json.key', return a labelled value.
+-- Version of 'keyLabel' that requires a proxy.
+--
+-- @@
+-- do
+--   txt <- keyLabel' (Proxy @"myLabel") "jsonKeyName" Json.asText
+--   pure (txt :: Label "myLabel" Text)
+-- @@
+keyLabel' ::
+  forall label err m a.
+  (Monad m) =>
+  Proxy label ->
+  Text ->
+  Json.ParseT err m a ->
+  Json.ParseT err m (Label label a)
+keyLabel' Proxy key parser = label @label <$> Json.key key parser
+
+-- | Parse an optional key from the object, à la 'Json.keyMay', return a labelled value.
+--
+-- We don’t provide a version that infers the json object key,
+-- since that conflates internal naming with the external API, which is dangerous.
+--
+-- @@
+-- do
+--   txt <- keyLabelMay @"myLabel" "jsonKeyName" Json.asText
+--   pure (txt :: Label "myLabel" (Maybe Text))
+-- @@
+keyLabelMay ::
+  forall label err m a.
+  (Monad m) =>
+  Text ->
+  Json.ParseT err m a ->
+  Json.ParseT err m (Label label (Maybe a))
+keyLabelMay = do
+  keyLabelMay' (Proxy @label)
+
+-- | Parse an optional key from the object, à la 'Json.keyMay', return a labelled value.
+-- Version of 'keyLabelMay' that requires a proxy.
+--
+-- @@
+-- do
+--   txt <- keyLabelMay' (Proxy @"myLabel") "jsonKeyName" Json.asText
+--   pure (txt :: Label "myLabel" (Maybe Text))
+-- @@
+keyLabelMay' ::
+  forall label err m a.
+  (Monad m) =>
+  Proxy label ->
+  Text ->
+  Json.ParseT err m a ->
+  Json.ParseT err m (Label label (Maybe a))
+keyLabelMay' Proxy key parser = label @label <$> Json.keyMay key parser
+
+-- NOTE: keyRenamed Test in "Json.JsonTest", due to import cycles.
+
+-- | Like 'Json.key', but allows a list of keys that are tried in order.
+--
+-- This is intended for renaming keys in an object.
+-- The first key is the most up-to-date version of a key, the others are for backward-compatibility.
+--
+-- If a key (new or old) exists, the inner parser will always be executed for that key.
+keyRenamed :: (Monad m) => NonEmpty Text -> Json.ParseT err m a -> Json.ParseT err m a
+keyRenamed (newKey :| oldKeys) inner =
+  keyRenamedTryOldKeys oldKeys inner >>= \case
+    Nothing -> Json.key newKey inner
+    Just parse -> parse
+
+-- | Like 'Json.keyMay', but allows a list of keys that are tried in order.
+--
+-- This is intended for renaming keys in an object.
+-- The first key is the most up-to-date version of a key, the others are for backward-compatibility.
+--
+-- If a key (new or old) exists, the inner parser will always be executed for that key.
+keyRenamedMay :: (Monad m) => NonEmpty Text -> Json.ParseT err m a -> Json.ParseT err m (Maybe a)
+keyRenamedMay (newKey :| oldKeys) inner =
+  keyRenamedTryOldKeys oldKeys inner >>= \case
+    Nothing -> Json.keyMay newKey inner
+    Just parse -> Just <$> parse
+
+-- | Helper function for 'keyRenamed' and 'keyRenamedMay' that returns the parser for the first old key that exists, if any.
+keyRenamedTryOldKeys :: (Monad m) => [Text] -> Json.ParseT err m a -> Json.ParseT err m (Maybe (Json.ParseT err m a))
+keyRenamedTryOldKeys oldKeys inner = do
+  oldKeys & traverse tryOld <&> catMaybes <&> nonEmpty <&> \case
+    Nothing -> Nothing
+    Just (old :| _moreOld) -> Just old
+  where
+    tryOld key =
+      Json.keyMay key (pure ()) <&> \case
+        Just () -> Just $ Json.key key inner
+        Nothing -> Nothing
+
+-- | A simple type isomorphic to `()` that that transforms to an empty json object and parses
+data EmptyObject = EmptyObject
+  deriving stock (Show, Eq)
+
+instance FromJSON EmptyObject where
+  -- allow any fields, as long as its an object
+  parseJSON = withObject "EmptyObject" (\_ -> pure EmptyObject)
+
+instance ToJSON EmptyObject where
+  toJSON EmptyObject = Object mempty
+  toEncoding EmptyObject = toEncoding $ Object mempty
+
+-- | Create a json array from a list of json values.
+mkJsonArray :: [Value] -> Value
+mkJsonArray xs = xs & Vector.fromList & Array
diff --git a/users/Profpatsch/my-prelude/src/Json/Enc.hs b/users/Profpatsch/my-prelude/src/Json/Enc.hs
new file mode 100644
index 000000000000..c7cd6e4635e0
--- /dev/null
+++ b/users/Profpatsch/my-prelude/src/Json/Enc.hs
@@ -0,0 +1,272 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Json.Enc where
+
+import Data.Aeson (Encoding, Value (..))
+import Data.Aeson qualified as Json
+import Data.Aeson.Encode.Pretty qualified as Aeson.Pretty
+import Data.Aeson.Encoding qualified as AesonEnc
+import Data.Aeson.Encoding qualified as Json.Enc
+import Data.Aeson.Encoding qualified as Json.Encoding
+import Data.Aeson.Key qualified as Key
+import Data.Aeson.KeyMap (KeyMap)
+import Data.Aeson.KeyMap qualified as KeyMap
+import Data.ByteString.Base64 qualified as Base64
+import Data.ByteString.Lazy qualified as LazyBytes
+import Data.Containers.ListUtils (nubOrdOn)
+import Data.Int (Int64)
+import Data.List qualified as List
+import Data.Map.Strict qualified as Map
+import Data.Scientific
+import Data.String (IsString (fromString))
+import Data.Text.Lazy qualified as Lazy
+import Data.Text.Lazy.Builder qualified as Text.Builder
+import Data.Time qualified as Time
+import Data.Time.Format.ISO8601 qualified as ISO8601
+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
+import PossehlAnalyticsPrelude
+
+-- | A JSON encoder.
+--
+-- It is faster than going through 'Value', because 'Encoding' is just a wrapper around a @Bytes.Builder@.
+-- But the @aeson@ interface for 'Encoding' is extremely bad, so let’s build a better one.
+newtype Enc = Enc {unEnc :: Encoding}
+  deriving (Num, Fractional) via (NumLiteralOnly "Enc" Enc)
+
+instance Show Enc where
+  show e = e.unEnc & Json.Encoding.encodingToLazyByteString & bytesToTextUtf8UnsafeLazy & show
+
+-- | You can create an @Enc any@ that renders a json string value with @OverloadedStrings@.
+instance IsString Enc where
+  fromString = Enc . AesonEnc.string
+
+-- | You can create an @Enc any@ that renders a json number value with an integer literal.
+instance IntegerLiteral Enc where
+  integerLiteral = Enc . AesonEnc.integer
+
+-- | You can create an @Enc any@ that renders a json number value with an floating point literal.
+--
+-- __ATTN__: Bear in mind that this will crash on repeating rationals, so only use for literals in code!
+instance RationalLiteral Enc where
+  rationalLiteral r = Enc $ AesonEnc.scientific (r & fromRational @Scientific)
+
+-- | Convert an 'Enc' to a strict UTF8-bytestring which is valid JSON (minified).
+encToBytesUtf8 :: Enc -> ByteString
+encToBytesUtf8 enc = enc & encToBytesUtf8Lazy & toStrictBytes
+
+-- | Convert an 'Enc' to a lazy UTF8-bytestring which is valid JSON (minified).
+encToBytesUtf8Lazy :: Enc -> LazyBytes.ByteString
+encToBytesUtf8Lazy enc = enc.unEnc & Json.Enc.encodingToLazyByteString
+
+-- | Convert an 'Enc' to a strict Text which is valid JSON (prettyfied).
+--
+-- __ATTN__: will re-parse the json through 'Json.Value', so only use for user-interactions like pretty-printing.
+encToTextPretty :: Enc -> Text
+encToTextPretty enc =
+  enc
+    & encToTextPrettyLazy
+    & toStrict
+
+-- | Convert an 'Enc' to a lazy Text which is valid JSON (prettyfied).
+--
+-- __ATTN__: will re-parse the json through 'Json.Value', so only use for user-interactions like pretty-printing.
+encToTextPrettyLazy :: Enc -> Lazy.Text
+encToTextPrettyLazy enc =
+  enc
+    & encToBytesUtf8Lazy
+    & Json.decode @Json.Value
+    & annotate "the json parser can’t parse json encodings??"
+    & unwrapError
+    & Aeson.Pretty.encodePrettyToTextBuilder
+    & Text.Builder.toLazyText
+
+-- | Embed a 'Json.Encoding' verbatim (it’s a valid JSON value)
+encoding :: Encoding -> Enc
+encoding = Enc
+
+-- | Encode a 'Json.Value' verbatim (it’s a valid JSON value)
+value :: Value -> Enc
+value = Enc . AesonEnc.value
+
+-- | Encode an empty json list
+emptyArray :: Enc
+emptyArray = Enc AesonEnc.emptyArray_
+
+-- | Encode an empty json dict
+emptyObject :: Enc
+emptyObject = Enc AesonEnc.emptyObject_
+
+-- | Encode a 'Text' as a json string
+text :: Text -> Enc
+text = Enc . AesonEnc.text
+
+-- | Encode a lazy 'Text' as a json string
+lazyText :: Lazy.Text -> Enc
+lazyText = Enc . AesonEnc.lazyText
+
+-- | Encode a 'ByteString' as a base64-encoded json string
+base64Bytes :: ByteString -> Enc
+base64Bytes = Enc . AesonEnc.text . bytesToTextUtf8Unsafe . Base64.encode
+
+-- | Encode a 'Text' as a base64-encoded json string
+base64 :: Text -> Enc
+base64 = Enc . AesonEnc.text . bytesToTextUtf8Unsafe . Base64.encode . textToBytesUtf8
+
+-- | Encode a 'Prelude.String' as a json string
+string :: String -> Enc
+string = Enc . AesonEnc.string
+
+-- | Encode as json @null@ if 'Nothing', else use the given encoder for @Just a@
+nullOr :: (a -> Enc) -> Maybe a -> Enc
+nullOr inner = \case
+  Nothing -> Enc AesonEnc.null_
+  Just a -> inner a
+
+-- | Encode a list as a json list
+list :: (a -> Enc) -> [a] -> Enc
+list f = Enc . AesonEnc.list (\a -> (f a).unEnc)
+
+-- | Encode a 'NonEmpty' as a json list.
+nonEmpty :: (a -> Enc) -> NonEmpty a -> Enc
+nonEmpty f = list f . toList
+
+-- | Encode the given list of keys and their encoders as json dict.
+--
+-- If the list contains the same key multiple times, the first value in the list is retained:
+--
+-- @
+-- (object [ ("foo", 42), ("foo", 23) ])
+-- ~= "{\"foo\":42}"
+-- @
+object :: (Foldable t) => t (Text, Enc) -> Enc
+object m =
+  Enc $
+    AesonEnc.dict
+      AesonEnc.text
+      (\recEnc -> recEnc.unEnc)
+      (\f -> List.foldr (\(k, v) -> f k v))
+      (nubOrdOn fst $ toList m)
+
+-- | A tag/value encoder; See 'choice'
+data Choice = Choice Text Enc
+
+-- | Encode a sum type as a @Choice@, an object with a @tag@/@value@ pair,
+-- which is the conventional json sum type representation in our codebase.
+--
+-- @
+-- foo :: Maybe Text -> Enc
+-- foo = choice $ \case
+--   Nothing -> Choice "no" emptyObject ()
+--   Just t -> Choice "yes" text t
+--
+-- ex = foo Nothing == "{\"tag\": \"no\", \"value\": {}}"
+-- ex2 = foo (Just "hi") == "{\"tag\": \"yes\", \"value\": \"hi\"}"
+-- @
+choice :: (from -> Choice) -> from -> Enc
+choice f from = case f from of
+  Choice key encA -> singleChoice key encA
+
+-- | Like 'choice', but simply encode a single possibility into a @tag/value@ object.
+-- This can be useful, but if you want to match on an enum, use 'choice' instead.
+singleChoice :: Text -> Enc -> Enc
+singleChoice key encA =
+  Enc $
+    AesonEnc.pairs $
+      mconcat
+        [ AesonEnc.pair "tag" (AesonEnc.text key),
+          AesonEnc.pair "value" encA.unEnc
+        ]
+
+-- | Encode a 'Map' as a json dict
+--
+-- We can’t really set the key to anything but text (We don’t keep the tag of 'Encoding')
+-- so instead we allow anything that’s coercible from text as map key (i.e. newtypes).
+map :: forall k v. (Coercible k Text) => (v -> Enc) -> Map k v -> Enc
+map valEnc m =
+  Enc $
+    AesonEnc.dict
+      (AesonEnc.text . coerce @k @Text)
+      (\v -> (valEnc v).unEnc)
+      Map.foldrWithKey
+      m
+
+-- | Encode a 'KeyMap' as a json dict
+keyMap :: (v -> Enc) -> KeyMap v -> Enc
+keyMap valEnc m =
+  Enc $
+    AesonEnc.dict
+      (AesonEnc.text . Key.toText)
+      (\v -> (valEnc v).unEnc)
+      KeyMap.foldrWithKey
+      m
+
+-- | Encode 'Json.Null'
+null :: Enc
+null = Enc AesonEnc.null_
+
+-- | Encode a 'Prelude.Bool' as a json boolean
+bool :: Bool -> Enc
+bool = Enc . AesonEnc.bool
+
+-- | Encode an 'Integer' as a json number.
+-- TODO: is it okay to just encode an arbitrarily-sized integer into json?
+integer :: Integer -> Enc
+integer = Enc . AesonEnc.integer
+
+-- | Encode a 'Scientific' as a json number.
+scientific :: Scientific -> Enc
+scientific = Enc . AesonEnc.scientific
+
+-- | Encode a 'Natural' as a json number.
+natural :: Natural -> Enc
+natural = integer . toInteger @Natural
+
+-- | Encode an 'Int' as a json number.
+int :: Int -> Enc
+int = Enc . AesonEnc.int
+
+-- | Encode an 'Int64' as a json number.
+int64 :: Int64 -> Enc
+int64 = Enc . AesonEnc.int64
+
+-- | Encode 'Time.UTCTime' as a json string, as an ISO8601 timestamp with timezone (@yyyy-mm-ddThh:mm:ss[.sss]Z@)
+utcTime :: Time.UTCTime -> Enc
+utcTime =
+  text . stringToText . ISO8601.iso8601Show @Time.UTCTime
+
+-- | Implement this class if you want your type to only implement the part of 'Num'
+-- that allows creating them from Integer-literals, then derive Num via 'NumLiteralOnly':
+--
+-- @
+-- data Foo = Foo Integer
+--   deriving (Num) via (NumLiteralOnly "Foo" Foo)
+--
+-- instance IntegerLiteral Foo where
+--  integerLiteral i = Foo i
+-- @
+class IntegerLiteral a where
+  integerLiteral :: Integer -> a
+
+-- | The same as 'IntegerLiteral' but for floating point literals.
+class RationalLiteral a where
+  rationalLiteral :: Rational -> a
+
+-- | Helper class for @deriving (Num) via …@, implements only literal syntax for integer and floating point numbers,
+-- and throws descriptive runtime errors for any other methods in 'Num'.
+--
+-- See 'IntegerLiteral' and 'RationalLiteral' for examples.
+newtype NumLiteralOnly (sym :: Symbol) num = NumLiteralOnly num
+
+instance (IntegerLiteral num, KnownSymbol sym) => Num (NumLiteralOnly sym num) where
+  fromInteger = NumLiteralOnly . integerLiteral
+  (+) = error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to add (+) (NumLiteralOnly)|]
+  (*) = error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to multiply (*) (NumLiteralOnly)|]
+  (-) = error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to subtract (-) (NumLiteralOnly)|]
+  abs = error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to use `abs` (NumLiteralOnly)|]
+  signum = error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to use `signum` (NumLiteralOnly)|]
+
+instance (IntegerLiteral num, RationalLiteral num, KnownSymbol sym) => Fractional (NumLiteralOnly sym num) where
+  fromRational = NumLiteralOnly . rationalLiteral
+  recip = error [fmt|Only use as rational literal allowed for {symbolVal (Proxy @sym)}, you tried to use `recip` (NumLiteralOnly)|]
+  (/) = error [fmt|Only use as numeric literal allowed for {symbolVal (Proxy @sym)}, you tried to divide (/) (NumLiteralOnly)|]
diff --git a/users/Profpatsch/my-prelude/src/Postgres/Decoder.hs b/users/Profpatsch/my-prelude/src/Postgres/Decoder.hs
index 008b89b4ba3d..92fe5cc7d2fe 100644
--- a/users/Profpatsch/my-prelude/src/Postgres/Decoder.hs
+++ b/users/Profpatsch/my-prelude/src/Postgres/Decoder.hs
@@ -8,6 +8,8 @@ import Data.Typeable (Typeable)
 import Database.PostgreSQL.Simple (Binary (fromBinary))
 import Database.PostgreSQL.Simple.FromField qualified as PG
 import Database.PostgreSQL.Simple.FromRow qualified as PG
+import FieldParser (FieldParser)
+import FieldParser qualified as Field
 import Json qualified
 import Label
 import PossehlAnalyticsPrelude
@@ -24,12 +26,65 @@ bytea = fromField @(Binary ByteString) <&> (.fromBinary)
 byteaMay :: Decoder (Maybe ByteString)
 byteaMay = fromField @(Maybe (Binary ByteString)) <&> fmap (.fromBinary)
 
+-- | Parse a `text` field.
+text :: Decoder Text
+text = fromField @Text
+
+-- | Parse a nullable `text` field.
+textMay :: Decoder (Maybe Text)
+textMay = fromField @(Maybe Text)
+
+-- | Parse a `text` field, and then use a 'FieldParser' to convert the result further.
+textParse :: (Typeable to) => FieldParser Text to -> Decoder to
+textParse = parse @Text
+
+-- | Parse a nullable `text` field, and then use a 'FieldParser' to convert the result further.
+textParseMay :: (Typeable to) => FieldParser Text to -> Decoder (Maybe to)
+textParseMay = parseMay @Text
+
+-- | Parse a type implementing 'FromField', and then use a 'FieldParser' to convert the result further.
+parse ::
+  forall from to.
+  ( PG.FromField from,
+    Typeable to
+  ) =>
+  FieldParser from to ->
+  Decoder to
+parse parser = Decoder $ PG.fieldWith $ \field bytes -> do
+  val <- PG.fromField @from field bytes
+  case Field.runFieldParser parser val of
+    Left err ->
+      PG.returnError
+        PG.ConversionFailed
+        field
+        (err & prettyError & textToString)
+    Right a -> pure a
+
+-- | Parse a nullable type implementing 'FromField', and then use a 'FieldParser' to convert the result further.
+parseMay ::
+  forall from to.
+  ( PG.FromField from,
+    Typeable to
+  ) =>
+  FieldParser from to ->
+  Decoder (Maybe to)
+parseMay parser = Decoder $ PG.fieldWith $ \field bytes -> do
+  val <- PG.fromField @(Maybe from) field bytes
+  case Field.runFieldParser parser <$> val of
+    Nothing -> pure Nothing
+    Just (Left err) ->
+      PG.returnError
+        PG.ConversionFailed
+        field
+        (err & prettyError & textToString)
+    Just (Right a) -> pure (Just a)
+
 -- | Turn any type that implements 'PG.fromField' into a 'Decoder'. Use type applications to prevent accidental conversions:
 --
 -- @
 -- fromField @Text :: Decoder Text
 -- @
-fromField :: PG.FromField a => Decoder a
+fromField :: (PG.FromField a) => Decoder a
 fromField = Decoder $ PG.fieldWith PG.fromField
 
 -- | Turn any type that implements 'PG.fromField' into a 'Decoder' and wrap the result into the given 'Label'. Use type applications to prevent accidental conversions:
@@ -37,7 +92,7 @@ fromField = Decoder $ PG.fieldWith PG.fromField
 -- @
 -- fromField @"myField" @Text :: Decoder (Label "myField" Text)
 -- @
-fromFieldLabel :: forall lbl a. PG.FromField a => Decoder (Label lbl a)
+fromFieldLabel :: forall lbl a. (PG.FromField a) => Decoder (Label lbl a)
 fromFieldLabel = label @lbl <$> fromField
 
 -- | Parse fields out of a json value returned from the database.
@@ -55,7 +110,7 @@ fromFieldLabel = label @lbl <$> fromField
 --
 -- Also note: `->>` will coerce the json value to @text@, regardless of the content.
 -- So the JSON object @{"foo": {}}"@ would be returned as the text: @"{\"foo\": {}}"@.
-json :: Typeable a => Json.ParseT ErrorTree Identity a -> Decoder a
+json :: (Typeable a) => Json.ParseT ErrorTree Identity a -> Decoder a
 json parser = Decoder $ PG.fieldWith $ \field bytes -> do
   val <- PG.fromField @Json.Value field bytes
   case Json.parseValue parser val of
@@ -81,7 +136,7 @@ json parser = Decoder $ PG.fieldWith $ \field bytes -> do
 --
 -- Also note: `->>` will coerce the json value to @text@, regardless of the content.
 -- So the JSON object @{"foo": {}}"@ would be returned as the text: @"{\"foo\": {}}"@.
-jsonMay :: Typeable a => Json.ParseT ErrorTree Identity a -> Decoder (Maybe a)
+jsonMay :: (Typeable a) => Json.ParseT ErrorTree Identity a -> Decoder (Maybe a)
 jsonMay parser = Decoder $ PG.fieldWith $ \field bytes -> do
   val <- PG.fromField @(Maybe Json.Value) field bytes
   case Json.parseValue parser <$> val of
diff --git a/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs b/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs
index 2c9a48d134ef..87928678a052 100644
--- a/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs
+++ b/users/Profpatsch/my-prelude/src/Postgres/MonadPostgres.hs
@@ -34,10 +34,11 @@ import Database.PostgreSQL.Simple qualified as Postgres
 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 Database.PostgreSQL.Simple.Types (PGArray (PGArray), Query (..))
 import GHC.IO.Handle (Handle)
 import GHC.Records (getField)
 import Label
+import Language.Haskell.TH.Quote (QuasiQuoter)
 import OpenTelemetry.Trace.Core (NewEvent (newEventName))
 import OpenTelemetry.Trace.Core qualified as Otel hiding (inSpan, inSpan')
 import OpenTelemetry.Trace.Monad qualified as Otel
@@ -45,6 +46,7 @@ import PossehlAnalyticsPrelude
 import Postgres.Decoder
 import Postgres.Decoder qualified as Dec
 import Pretty (showPretty)
+import PyF qualified
 import Seconds
 import System.Exit (ExitCode (..))
 import Tool
@@ -140,6 +142,10 @@ class (Monad m) => MonadPostgres (m :: Type -> Type) where
   -- Only handlers should run transactions.
   runTransaction :: Transaction m a -> m a
 
+-- | Quasi-Quoter for multi-line SQL literals. Trims leading whitespace up to the least-indented line.
+sql :: QuasiQuoter
+sql = PyF.fmtTrim
+
 -- | Run a query, passing parameters. Prefer 'queryWith' if possible.
 query ::
   forall m params r.
@@ -364,20 +370,19 @@ addErrorInformation msg io =
 -- print the query that was run and the query parameters,
 -- then rethrow inside an 'Error'.
 handlePGException ::
-  forall a params tools m.
+  forall a params m.
   ( ToRow params,
     MonadUnliftIO m,
-    MonadLogger m,
-    HasField "pgFormat" tools PgFormatPool
+    MonadLogger m
   ) =>
-  tools ->
+  PrettyPrintDatabaseQueries ->
   Text ->
   Query ->
   -- | Depending on whether we used `format` or `formatMany`.
   Either params (NonEmpty params) ->
   IO a ->
   Transaction m a
-handlePGException tools queryType query' params io = do
+handlePGException prettyQuery queryType query' params io = do
   withRunInIO $ \unliftIO ->
     io
       `catches` [ Handler $ unliftIO . logQueryException @SqlError,
@@ -391,13 +396,14 @@ handlePGException tools queryType query' params io = do
     throwErr err = liftIO $ throwAsError $ prettyErrorTree $ nestedMultiError "A Postgres query failed" err
     logQueryException :: (Exception e) => e -> Transaction m a
     logQueryException exc = do
-      formattedQuery <- case params of
-        Left one -> pgFormatQuery' tools query' one
-        Right many -> pgFormatQueryMany' tools query' many
+      formattedQuery <-
+        case params of
+          Left one -> pgFormatQuery' prettyQuery query' one
+          Right many -> pgFormatQueryMany' prettyQuery query' many
       throwErr
         ( singleError [fmt|Query Type: {queryType}|]
             :| [ nestedError "Exception" (exc & showPretty & newError & singleError),
-                 nestedError "Query" (formattedQuery & newError & singleError)
+                 nestedError "Query" (formattedQuery & bytesToTextUtf8Lenient & newError & singleError)
                ]
         )
     logFormatException :: FormatError -> Transaction m a
@@ -527,55 +533,52 @@ runPGTransactionImpl zoom (Transaction transaction) = do
       unliftIO $ runReaderT transaction conn
 
 executeImpl ::
-  (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) =>
-  m tools ->
-  m DebugLogDatabaseQueries ->
+  (ToRow params, MonadUnliftIO m, MonadLogger m, Otel.MonadTracer m) =>
+  m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
   Query ->
   params ->
   Transaction m (Label "numberOfRowsAffected" Natural)
 {-# INLINE executeImpl #-}
-executeImpl zoomTools zoomDebugLogDatabaseQueries qry params =
+executeImpl zoomDbOptions qry params =
   Otel.inSpan' "Postgres Query (execute)" Otel.defaultSpanArguments $ \span -> do
-    tools <- lift @Transaction zoomTools
-    logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
-    traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params)
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
+    traceQueryIfEnabled span logDatabaseQueries prettyQuery qry (HasSingleParam params)
     conn <- Transaction ask
     PG.execute conn qry params
-      & handlePGException tools "execute" qry (Left params)
+      & handlePGException prettyQuery "execute" qry (Left params)
       >>= toNumberOfRowsAffected "executeImpl"
 
 executeImpl_ ::
-  (MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) =>
-  m tools ->
-  m DebugLogDatabaseQueries ->
+  ( MonadUnliftIO m,
+    MonadLogger m,
+    Otel.MonadTracer m
+  ) =>
+  m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
   Query ->
   Transaction m (Label "numberOfRowsAffected" Natural)
 {-# INLINE executeImpl_ #-}
-executeImpl_ zoomTools zoomDebugLogDatabaseQueries qry =
+executeImpl_ zoomDbOptions qry =
   Otel.inSpan' "Postgres Query (execute)" Otel.defaultSpanArguments $ \span -> do
-    tools <- lift @Transaction zoomTools
-    logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
-    traceQueryIfEnabled @() tools span logDatabaseQueries qry HasNoParams
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
+    traceQueryIfEnabled @() span logDatabaseQueries prettyQuery qry HasNoParams
     conn <- Transaction ask
     PG.execute_ conn qry
-      & handlePGException tools "execute_" qry (Left ())
+      & handlePGException prettyQuery "execute_" qry (Left ())
       >>= toNumberOfRowsAffected "executeImpl_"
 
 executeManyImpl ::
-  (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) =>
-  m tools ->
-  m DebugLogDatabaseQueries ->
+  (ToRow params, MonadUnliftIO m, MonadLogger m, Otel.MonadTracer m) =>
+  m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
   Query ->
   NonEmpty params ->
   Transaction m (Label "numberOfRowsAffected" Natural)
-executeManyImpl zoomTools zoomDebugLogDatabaseQueries qry params =
+executeManyImpl zoomDbOptions qry params =
   Otel.inSpan' "Postgres Query (executeMany)" Otel.defaultSpanArguments $ \span -> do
-    tools <- lift @Transaction zoomTools
-    logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
-    traceQueryIfEnabled tools span logDatabaseQueries qry (HasMultiParams params)
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
+    traceQueryIfEnabled span logDatabaseQueries prettyQuery qry (HasMultiParams params)
     conn <- Transaction ask
     PG.executeMany conn qry (params & toList)
-      & handlePGException tools "executeMany" qry (Right params)
+      & handlePGException prettyQuery "executeMany" qry (Right params)
       >>= toNumberOfRowsAffected "executeManyImpl"
 
 toNumberOfRowsAffected :: (MonadIO m) => Text -> Int64 -> m (Label "numberOfRowsAffected" Natural)
@@ -589,32 +592,32 @@ toNumberOfRowsAffected functionName i64 =
     <&> label @"numberOfRowsAffected"
 
 executeManyReturningWithImpl ::
-  (ToRow params, MonadUnliftIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool, Otel.MonadTracer m) =>
-  m tools ->
-  m DebugLogDatabaseQueries ->
+  ( ToRow params,
+    MonadUnliftIO m,
+    MonadLogger m,
+    Otel.MonadTracer m
+  ) =>
+  m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
   Query ->
   NonEmpty params ->
   Decoder r ->
   Transaction m [r]
 {-# INLINE executeManyReturningWithImpl #-}
-executeManyReturningWithImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder fromRow) = do
+executeManyReturningWithImpl zoomDbOptions qry params (Decoder fromRow) = do
   Otel.inSpan' "Postgres Query (executeManyReturning)" Otel.defaultSpanArguments $ \span -> do
-    tools <- lift @Transaction zoomTools
-    logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
-    traceQueryIfEnabled tools span logDatabaseQueries qry (HasMultiParams params)
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
+    traceQueryIfEnabled span logDatabaseQueries prettyQuery qry (HasMultiParams params)
     conn <- Transaction ask
     PG.returningWith fromRow conn qry (params & toList)
-      & handlePGException tools "executeManyReturning" qry (Right params)
+      & handlePGException prettyQuery "executeManyReturning" qry (Right params)
 
 foldRowsWithAccImpl ::
   ( ToRow params,
     MonadUnliftIO m,
     MonadLogger m,
-    HasField "pgFormat" tools PgFormatPool,
     Otel.MonadTracer m
   ) =>
-  m tools ->
-  m DebugLogDatabaseQueries ->
+  m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
   Query ->
   params ->
   Decoder row ->
@@ -622,11 +625,10 @@ foldRowsWithAccImpl ::
   (a -> row -> Transaction m a) ->
   Transaction m a
 {-# INLINE foldRowsWithAccImpl #-}
-foldRowsWithAccImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder rowParser) accumulator f = do
+foldRowsWithAccImpl zoomDbOptions qry params (Decoder rowParser) accumulator f = do
   Otel.inSpan' "Postgres Query (foldRowsWithAcc)" Otel.defaultSpanArguments $ \span -> do
-    tools <- lift @Transaction zoomTools
-    logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
-    traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params)
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
+    traceQueryIfEnabled span logDatabaseQueries prettyQuery qry (HasSingleParam params)
     conn <- Transaction ask
     withRunInIO
       ( \runInIO ->
@@ -639,17 +641,18 @@ foldRowsWithAccImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder ro
               params
               accumulator
               (\acc row -> runInIO $ f acc row)
-              & handlePGException tools "fold" qry (Left params)
+              & handlePGException prettyQuery "fold" qry (Left params)
               & runInIO
       )
 
 pgFormatQueryNoParams' ::
-  (MonadIO m, MonadLogger m, HasField "pgFormat" tools PgFormatPool) =>
-  tools ->
+  (MonadIO m, MonadLogger m) =>
+  PrettyPrintDatabaseQueries ->
   Query ->
-  Transaction m Text
-pgFormatQueryNoParams' tools q =
-  lift $ pgFormatQueryByteString tools q.fromQuery
+  Transaction m ByteString
+pgFormatQueryNoParams' prettyQuery q = case prettyQuery of
+  DontPrettyPrintDatabaseQueries -> pure q.fromQuery
+  PrettyPrintDatabaseQueries pool -> lift $ pgFormatQueryByteString pool q.fromQuery
 
 pgFormatQuery ::
   (ToRow params, MonadIO m) =>
@@ -680,40 +683,36 @@ queryWithImpl ::
   ( ToRow params,
     MonadUnliftIO m,
     MonadLogger m,
-    HasField "pgFormat" tools PgFormatPool,
     Otel.MonadTracer m
   ) =>
-  m tools ->
-  m DebugLogDatabaseQueries ->
+  m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) ->
   Query ->
   params ->
   Decoder r ->
   Transaction m [r]
 {-# INLINE queryWithImpl #-}
-queryWithImpl zoomTools zoomDebugLogDatabaseQueries qry params (Decoder fromRow) = do
+queryWithImpl zoomDbOptions qry params (Decoder fromRow) = do
   Otel.inSpan' "Postgres Query (queryWith)" Otel.defaultSpanArguments $ \span -> do
-    tools <- lift @Transaction zoomTools
-    logDatabaseQueries <- lift @Transaction zoomDebugLogDatabaseQueries
-    traceQueryIfEnabled tools span logDatabaseQueries qry (HasSingleParam params)
+    (logDatabaseQueries, prettyQuery) <- lift @Transaction zoomDbOptions
+    traceQueryIfEnabled span logDatabaseQueries prettyQuery qry (HasSingleParam params)
     conn <- Transaction ask
     PG.queryWith fromRow conn qry params
-      & handlePGException tools "query" qry (Left params)
+      & handlePGException prettyQuery "query" qry (Left params)
 
 queryWithImpl_ ::
   ( MonadUnliftIO m,
-    MonadLogger m,
-    HasField "pgFormat" tools PgFormatPool
+    MonadLogger m
   ) =>
-  m tools ->
+  m PrettyPrintDatabaseQueries ->
   Query ->
   Decoder r ->
   Transaction m [r]
 {-# INLINE queryWithImpl_ #-}
-queryWithImpl_ zoomTools qry (Decoder fromRow) = do
-  tools <- lift @Transaction zoomTools
+queryWithImpl_ zoomDbOptions qry (Decoder fromRow) = do
+  prettyQuery <- lift @Transaction zoomDbOptions
   conn <- Transaction ask
   liftIO (PG.queryWith_ fromRow conn qry)
-    & handlePGException tools "query" qry (Left ())
+    & handlePGException prettyQuery "query" qry (Left ())
 
 data SingleRowError = SingleRowError
   { -- | How many columns were actually returned by the query
@@ -727,30 +726,32 @@ instance Exception SingleRowError where
 pgFormatQuery' ::
   ( MonadIO m,
     ToRow params,
-    MonadLogger m,
-    HasField "pgFormat" tools PgFormatPool
+    MonadLogger m
   ) =>
-  tools ->
+  PrettyPrintDatabaseQueries ->
   Query ->
   params ->
-  Transaction m Text
-pgFormatQuery' tools q p =
-  pgFormatQuery q p
-    >>= lift . pgFormatQueryByteString tools
+  Transaction m ByteString
+pgFormatQuery' prettyQuery q p = case prettyQuery of
+  DontPrettyPrintDatabaseQueries -> pgFormatQuery q p
+  PrettyPrintDatabaseQueries pool ->
+    pgFormatQuery q p
+      >>= lift . pgFormatQueryByteString pool
 
 pgFormatQueryMany' ::
   ( MonadIO m,
     ToRow params,
-    MonadLogger m,
-    HasField "pgFormat" tools PgFormatPool
+    MonadLogger m
   ) =>
-  tools ->
+  PrettyPrintDatabaseQueries ->
   Query ->
   NonEmpty params ->
-  Transaction m Text
-pgFormatQueryMany' tools q p =
-  pgFormatQueryMany q p
-    >>= lift . pgFormatQueryByteString tools
+  Transaction m ByteString
+pgFormatQueryMany' prettyQuery q p = case prettyQuery of
+  DontPrettyPrintDatabaseQueries -> pgFormatQueryMany q p
+  PrettyPrintDatabaseQueries pool ->
+    pgFormatQueryMany q p
+      >>= lift . pgFormatQueryByteString pool
 
 -- | Read the executable name "pg_format"
 postgresToolsParser :: ToolParserT IO (Label "pgFormat" Tool)
@@ -758,20 +759,19 @@ postgresToolsParser = label @"pgFormat" <$> readTool "pg_format"
 
 pgFormatQueryByteString ::
   ( MonadIO m,
-    MonadLogger m,
-    HasField "pgFormat" tools PgFormatPool
+    MonadLogger m
   ) =>
-  tools ->
+  PgFormatPool ->
   ByteString ->
-  m Text
-pgFormatQueryByteString tools queryBytes = do
+  m ByteString
+pgFormatQueryByteString pool queryBytes = do
   res <-
     liftIO $
       runPgFormat
-        tools.pgFormat
+        pool
         (queryBytes)
   case res.exitCode of
-    ExitSuccess -> pure (res.formatted & bytesToTextUtf8Lenient)
+    ExitSuccess -> pure (res.formatted)
     ExitFailure status -> do
       logWarn [fmt|pg_format failed with status {status} while formatting the query, using original query string. Is there a syntax error?|]
       logDebug
@@ -784,7 +784,7 @@ pgFormatQueryByteString tools queryBytes = do
             )
         )
       logDebug [fmt|pg_format stdout: stderr|]
-      pure (queryBytes & bytesToTextUtf8Lenient)
+      pure (queryBytes)
 
 pgFormatStartCommandWaitForInput ::
   ( MonadIO m,
@@ -821,6 +821,17 @@ data DebugLogDatabaseQueries
     LogDatabaseQueriesAndExplain
   deriving stock (Show, Enum, Bounded)
 
+-- | Whether to pipe database queries thru `pg_format` before logging them. This takes a long (long! 200ms+) time per query, so should only be used in debugging environments where speed is not an issue.
+data PrettyPrintDatabaseQueries
+  = -- | Do not pretty-print database querios
+    DontPrettyPrintDatabaseQueries
+  | -- | Pretty-print database queries, slow
+    PrettyPrintDatabaseQueries PgFormatPool
+
+instance Show PrettyPrintDatabaseQueries where
+  show DontPrettyPrintDatabaseQueries = "DontPrettyPrintDatabaseQueries"
+  show (PrettyPrintDatabaseQueries _) = "PrettyPrintDatabaseQueries"
+
 data HasQueryParams param
   = HasNoParams
   | HasSingleParam param
@@ -831,32 +842,31 @@ traceQueryIfEnabled ::
   ( ToRow params,
     MonadUnliftIO m,
     MonadLogger m,
-    HasField "pgFormat" tools PgFormatPool,
     Otel.MonadTracer m
   ) =>
-  tools ->
   Otel.Span ->
   DebugLogDatabaseQueries ->
+  PrettyPrintDatabaseQueries ->
   Query ->
   HasQueryParams params ->
   Transaction m ()
-traceQueryIfEnabled tools span logDatabaseQueries qry params = do
+traceQueryIfEnabled span logDatabaseQueries prettyQuery qry params = do
   -- In case we have query logging enabled, we want to do that
-  let formattedQuery = do
+  let formattedQuery =
         withEvent
           span
           "Query Format start"
           "Query Format end"
           $ case params of
-            HasNoParams -> pgFormatQueryNoParams' tools qry
-            HasSingleParam p -> pgFormatQuery' tools qry p
-            HasMultiParams ps -> pgFormatQueryMany' tools qry ps
+            HasNoParams -> pgFormatQueryNoParams' prettyQuery qry
+            HasSingleParam p -> pgFormatQuery' prettyQuery qry p
+            HasMultiParams ps -> pgFormatQueryMany' prettyQuery qry ps
 
   let doLog errs =
         Otel.addAttributes
           span
           $ HashMap.fromList
-          $ ( ("_.postgres.query", Otel.toAttribute @Text errs.query)
+          $ ( ("_.postgres.query", Otel.toAttribute @Text (errs.query & bytesToTextUtf8Lenient))
                 : ( errs.explain
                       & \case
                         Nothing -> []
@@ -867,12 +877,12 @@ traceQueryIfEnabled tools span logDatabaseQueries qry params = do
         q <- formattedQuery
         Otel.inSpan "Postgres EXPLAIN Query" Otel.defaultSpanArguments $ do
           queryWithImpl_
-            (pure tools)
+            (pure prettyQuery)
             ( "EXPLAIN "
                 <> (
                      -- TODO: this is not nice, but the only way to get the `executeMany` form to work with this
                      -- because we need the query with all elements already interpolated.
-                     Query (q & textToBytesUtf8)
+                     Query q
                    )
             )
             (Dec.fromField @Text)
@@ -920,6 +930,70 @@ withEvent span start end act = do
     )
   pure res
 
+unzipPGArray ::
+  forall l1 t1 l2 t2 r.
+  ( HasField l1 r t1,
+    HasField l2 r t2
+  ) =>
+  [r] ->
+  (PGArray t1, PGArray t2)
+{-# INLINEABLE unzipPGArray #-}
+unzipPGArray xs =
+  ( PGArray $ getField @l1 <$> xs,
+    PGArray $ getField @l2 <$> xs
+  )
+
+unzip3PGArray ::
+  forall l1 t1 l2 t2 l3 t3 r.
+  ( HasField l1 r t1,
+    HasField l2 r t2,
+    HasField l3 r t3
+  ) =>
+  [r] ->
+  (PGArray t1, PGArray t2, PGArray t3)
+{-# INLINEABLE unzip3PGArray #-}
+unzip3PGArray xs =
+  ( PGArray $ getField @l1 <$> xs,
+    PGArray $ getField @l2 <$> xs,
+    PGArray $ getField @l3 <$> xs
+  )
+
+unzip4PGArray ::
+  forall l1 t1 l2 t2 l3 t3 l4 t4 r.
+  ( HasField l1 r t1,
+    HasField l2 r t2,
+    HasField l3 r t3,
+    HasField l4 r t4
+  ) =>
+  [r] ->
+  (PGArray t1, PGArray t2, PGArray t3, PGArray t4)
+{-# INLINEABLE unzip4PGArray #-}
+unzip4PGArray xs =
+  ( PGArray $ getField @l1 <$> xs,
+    PGArray $ getField @l2 <$> xs,
+    PGArray $ getField @l3 <$> xs,
+    PGArray $ getField @l4 <$> xs
+  )
+
+unzip5PGArray ::
+  forall l1 t1 l2 t2 l3 t3 l4 t4 l5 t5 r.
+  ( HasField l1 r t1,
+    HasField l2 r t2,
+    HasField l3 r t3,
+    HasField l4 r t4,
+    HasField l5 r t5
+  ) =>
+  [r] ->
+  (PGArray t1, PGArray t2, PGArray t3, PGArray t4, PGArray t5)
+{-# INLINEABLE unzip5PGArray #-}
+unzip5PGArray xs =
+  ( PGArray $ getField @l1 <$> xs,
+    PGArray $ getField @l2 <$> xs,
+    PGArray $ getField @l3 <$> xs,
+    PGArray $ getField @l4 <$> xs,
+    PGArray $ getField @l5 <$> xs
+  )
+
 instance (ToField t1) => ToRow (Label l1 t1) where
   toRow t2 = toRow $ PG.Only $ getField @l1 t2
 
diff --git a/users/Profpatsch/my-prelude/src/Pretty.hs b/users/Profpatsch/my-prelude/src/Pretty.hs
index d9d4ce132b11..6711ea951a48 100644
--- a/users/Profpatsch/my-prelude/src/Pretty.hs
+++ b/users/Profpatsch/my-prelude/src/Pretty.hs
@@ -8,6 +8,7 @@ module Pretty
     printShowedStringPretty,
     -- constructors hidden
     prettyErrs,
+    prettyErrsNoColor,
     message,
     messageString,
     pretty,
@@ -19,6 +20,7 @@ where
 import Data.Aeson qualified as Json
 import Data.Aeson.Encode.Pretty qualified as Aeson.Pretty
 import Data.List qualified as List
+import Data.String (IsString (fromString))
 import Data.Text.Lazy.Builder qualified as Text.Builder
 import Language.Haskell.HsColour
   ( Output (TTYg),
@@ -62,7 +64,6 @@ showPrettyJson val =
     & toStrict
 
 -- | Display a list of 'Err's as a colored error message
--- and abort the test.
 prettyErrs :: [Err] -> String
 prettyErrs errs = res
   where
@@ -74,6 +75,15 @@ prettyErrs errs = res
     prettyShowString :: String -> String
     prettyShowString = hscolour' . nicify
 
+-- | Display a list of 'Err's as a plain-colored error message
+prettyErrsNoColor :: [Err] -> String
+prettyErrsNoColor errs = res
+  where
+    res = List.intercalate "\n" $ map one errs
+    one = \case
+      ErrMsg s -> s
+      ErrPrettyString s -> nicify s
+
 -- | Small DSL for pretty-printing errors
 data Err
   = -- | Message to display in the error
@@ -81,6 +91,9 @@ data Err
   | -- | Pretty print a String that was produced by 'show'
     ErrPrettyString String
 
+instance IsString Err where
+  fromString s = ErrMsg s
+
 -- | Plain message to display, as 'Text'
 message :: Text -> Err
 message = ErrMsg . textToString
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-10-11T23·24+0000