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

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>

1 files changed, 244 insertions, 44 deletions

diff --git a/users/Profpatsch/my-prelude/src/MyPrelude.hs b/users/Profpatsch/my-prelude/src/MyPrelude.hs
index 7857ace61fdb..cd246d172881 100644
--- a/users/Profpatsch/my-prelude/src/MyPrelude.hs
+++ b/users/Profpatsch/my-prelude/src/MyPrelude.hs
@@ -1,11 +1,7 @@
 {-# LANGUAGE ImplicitParams #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MagicHash #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fexpose-all-unfoldings #-}
+{-# LANGUAGE ViewPatterns #-}
 
 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.
-toNonEmptyDefault :: a -> [a] -> NonEmpty a
-toNonEmptyDefault def xs = case xs of
-  [] -> def :| []
-  (x : xs') -> x :| xs'
+-- | If the list is not empty, run the given function with a NonEmpty list, otherwise just return []
+overNonEmpty :: (Applicative f) => (NonEmpty a -> f [b]) -> [a] -> f [b]
+overNonEmpty f xs = case xs of
+  IsEmpty -> pure []
+  IsNonEmpty xs' -> f xs'
+
+-- | 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
 
--- | @O(n)@. Get the maximum element from a non-empty structure.
+-- | 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 ::
-  forall a k.
-  (Bounded a, Enum a, Ord k) =>
-  (a -> k) ->
-  Map k a
-inverseMap f =
-  universe
-    <&> (\a -> (f a, a))
-    & Map.fromList
-  where
-    universe :: [a]
-    universe = [minBound .. maxBound]
+inverseMap :: forall a k. (Bounded a, Enum a, Ord k) => (a -> k) -> Map k a
+inverseMap f = enumerateAll <&> (\a -> (f a, a)) & Map.fromList
+
+-- | All possible values in this enum.
+enumerateAll :: (Enum a, Bounded a) => [a]
+enumerateAll = [minBound .. maxBound]
+
+-- | Create a 'Map' from a list of values, extracting the map key from each value. Like 'Map.fromList'.
+--
+-- Attention: if the key is not unique, the earliest value with the key will be in the map.
+mapFromListOn :: (Ord key) => (a -> key) -> [a] -> Map key a
+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 = foldMap
+ifExists :: (Monoid m) => Maybe m -> m
+ifExists = fold