diff options
Diffstat (limited to 'users/Profpatsch/my-prelude/MyPrelude.hs')
| -rw-r--r-- | users/Profpatsch/my-prelude/MyPrelude.hs | 136 |
1 files changed, 91 insertions, 45 deletions
diff --git a/users/Profpatsch/my-prelude/MyPrelude.hs b/users/Profpatsch/my-prelude/MyPrelude.hs index a2c99bc9ead2..4ef59c05ffba 100644 --- a/users/Profpatsch/my-prelude/MyPrelude.hs +++ b/users/Profpatsch/my-prelude/MyPrelude.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GHC2021 #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} @@ -5,6 +6,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fexpose-all-unfoldings #-} module MyPrelude ( -- * Text conversions @@ -37,6 +39,9 @@ module MyPrelude -- * WIP code todo, + -- * Records + HasField, + -- * Control flow (&), (<&>), @@ -59,9 +64,11 @@ module MyPrelude first, second, bimap, + both, foldMap, fold, foldl', + fromMaybe, mapMaybe, findMaybe, Traversable, @@ -105,6 +112,8 @@ module MyPrelude sconcat, Monoid, mconcat, + ifTrue, + ifExists, Void, absurd, Identity (Identity, runIdentity), @@ -120,8 +129,8 @@ module MyPrelude rmap, Semigroupoid, Category, - (<<<), (>>>), + (&>>), -- * Enum definition inverseFunction, @@ -130,12 +139,11 @@ module MyPrelude -- * Error handling HasCallStack, module Data.Error, - smushErrors, ) where import Control.Applicative ((<|>)) -import Control.Category (Category, (<<<), (>>>)) +import Control.Category (Category, (>>>)) import Control.Monad (guard, join, unless, when) import Control.Monad.Except ( ExceptT, @@ -150,13 +158,13 @@ import Data.Bifunctor (Bifunctor, bimap, first, second) import Data.ByteString ( ByteString, ) -import qualified Data.ByteString.Lazy -import qualified Data.Char +import Data.ByteString.Lazy qualified +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 qualified Data.Foldable as Foldable +import Data.Foldable qualified as Foldable import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Functor.Contravariant (Contravariant (contramap), (>$<)) @@ -165,22 +173,22 @@ import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) import Data.Map.Strict ( Map, ) -import qualified Data.Map.Strict as Map -import Data.Maybe (mapMaybe) -import qualified Data.Maybe as Maybe +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.Semigroup.Foldable (Foldable1 (fold1), foldMap1) import Data.Semigroup.Traversable (Traversable1) -import Data.Semigroupoid (Semigroupoid) +import Data.Semigroupoid (Semigroupoid (o)) import Data.Text ( Text, ) -import qualified Data.Text -import qualified Data.Text.Encoding -import qualified Data.Text.Encoding.Error -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Encoding +import Data.Text qualified +import Data.Text.Encoding qualified +import Data.Text.Encoding.Error qualified +import Data.Text.Lazy qualified +import Data.Text.Lazy.Encoding qualified import Data.These (These (That, These, This)) import Data.Traversable (for) import Data.Void (Void, absurd) @@ -189,10 +197,11 @@ import GHC.Exception (errorCallWithCallStackException) import GHC.Exts (RuntimeRep, TYPE, raise#) import GHC.Generics (Generic) import GHC.Natural (Natural) +import GHC.Records (HasField) import GHC.Stack (HasCallStack) import PyF (fmt) -import qualified System.Exit -import qualified System.IO +import System.Exit qualified +import System.IO qualified import Validation ( Validation (Failure, Success), eitherToValidation, @@ -208,6 +217,20 @@ import Validation infixl 5 >&< +-- | Forward semigroupoid application. The same as '(>>>)', but 'Semigroupoid' is not a superclass of 'Category' (yet). +-- +-- 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 + +-- like >>> +infixr 1 &>> + -- | encode a Text to a UTF-8 encoded Bytestring textToBytesUtf8 :: Text -> ByteString textToBytesUtf8 = Data.Text.Encoding.encodeUtf8 @@ -309,6 +332,10 @@ annotate err = \case Nothing -> Left err Just a -> Right a +-- | Map the same function over both sides of a Bifunctor (e.g. a tuple). +both :: Bifunctor bi => (a -> b) -> bi a a -> bi b b +both f = bimap f f + -- | Find the first element for which pred returns `Just a`, and return the `a`. -- -- Example: @@ -430,33 +457,6 @@ traverseFold1 f xs = fold1 <$> traverse f xs todo :: forall (r :: RuntimeRep). forall (a :: TYPE r). HasCallStack => a todo = raise# (errorCallWithCallStackException "This code was not yet implemented: TODO" ?callStack) --- TODO: use a Text.Builder? - --- | Pretty print a bunch of errors, on multiple lines, prefixed by the given message, --- then turn the result back into an 'Error'. --- --- Example: --- --- smushErrors "There was a problem with the frobl" --- [ (anyhow "frobz") --- , (errorContext "oh no" (anyhow "barz")) --- ] --- --- ==> --- "There was a problem with the frobl\n\ --- - frobz\n\ --- - oh no: barz\n" --- @ --- --- TODO how do we make this compatible with/integrate it into the Error library? -smushErrors :: Foldable t => Text -> t Error -> Error -smushErrors msg errs = - errs - -- hrm, pretty printing and then creating a new error is kinda shady - & foldMap (\err -> "\n- " <> prettyError err) - & newError - & errorContext msg - -- | Convert an integer to a 'Natural' if possible -- -- Named the same as the function from "GHC.Natural", but does not crash. @@ -536,5 +536,51 @@ inverseMap f = <&> (\a -> (f a, a)) & Map.fromList where - universe :: (Bounded a, Enum a) => [a] + universe :: [a] universe = [minBound .. maxBound] + +-- | If the predicate is true, return the @m@, else 'mempty'. +-- +-- This can be used (together with `ifExists`) to e.g. create lists with optional elements: +-- +-- >>> import Data.Monoid (Sum(..)) +-- +-- >>> :{ mconcat [ +-- ifTrue (1 == 1) [1], +-- [2, 3, 4], +-- ifTrue False [5], +-- ] +-- :} +-- [1,2,3,4] +-- +-- Or any other Monoid: +-- +-- >>> mconcat [ Sum 1, ifTrue (1 == 1) (Sum 2), Sum 3 ] + +-- Sum {getSum = 6} + +ifTrue :: Monoid m => Bool -> m -> m +ifTrue pred' m = if pred' then m else mempty + +-- | If the given @Maybe@ is @Just@, return the @m@, else return mempty. + +-- This can be used (together with `ifTrue`) to e.g. create lists with optional elements: +-- +-- >>> import Data.Monoid (Sum(..)) +-- +-- >>> :{ mconcat [ +-- ifExists (Just [1]), +-- [2, 3, 4], +-- ifExists Nothing, +-- ] +-- :} +-- [1,2,3,4] +-- +-- Or any other Monoid: +-- +-- >>> mconcat [ Sum 1, ifExists (Just (Sum 2)), Sum 3 ] + +-- Sum {getSum = 6} + +ifExists :: Monoid m => Maybe m -> m +ifExists = fold |