diff options
Diffstat (limited to 'users/Profpatsch/my-prelude/src/MyPrelude.hs')
| -rw-r--r-- | users/Profpatsch/my-prelude/src/MyPrelude.hs | 288 |
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 7857ace61f..cd246d1728 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 |