diff options
Diffstat (limited to 'users/Profpatsch/my-prelude')
| -rw-r--r-- | users/Profpatsch/my-prelude/MyPrelude.hs | 136 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/Pretty.hs | 87 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/default.nix | 4 | ||||
| -rw-r--r-- | users/Profpatsch/my-prelude/my-prelude.cabal | 4 |
4 files changed, 186 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 diff --git a/users/Profpatsch/my-prelude/Pretty.hs b/users/Profpatsch/my-prelude/Pretty.hs new file mode 100644 index 000000000000..8a58a5934e17 --- /dev/null +++ b/users/Profpatsch/my-prelude/Pretty.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} + +module Pretty + ( -- * Pretty printing for error messages + Err, + printPretty, + -- constructors hidden + prettyErrs, + message, + messageString, + pretty, + prettyString, + hscolour', + ) +where + +import Data.List qualified as List +import Data.Text qualified as Text +import Language.Haskell.HsColour + ( Output (TTYg), + hscolour, + ) +import Language.Haskell.HsColour.ANSI (TerminalType (..)) +import Language.Haskell.HsColour.Colourise + ( defaultColourPrefs, + ) +import MyPrelude +import System.Console.ANSI (setSGRCode) +import System.Console.ANSI.Types + ( Color (Red), + ColorIntensity (Dull), + ConsoleLayer (Foreground), + SGR (Reset, SetColor), + ) +import Text.Nicify (nicify) + +-- | Print any 'Show'able type to stderr, formatted nicely and in color. Very helpful for debugging. +printPretty :: Show a => a -> IO () +printPretty a = + a & pretty & (: []) & prettyErrs & stringToText & putStderrLn + +-- | Display a list of 'Err's as a colored error message +-- and abort the test. +prettyErrs :: [Err] -> String +prettyErrs errs = res + where + res = List.intercalate "\n" $ map one errs + one = \case + ErrMsg s -> color Red s + ErrPrettyString s -> prettyShowString s + -- Pretty print a String that was produced by 'show' + prettyShowString :: String -> String + prettyShowString = hscolour' . nicify + +-- | Small DSL for pretty-printing errors +data Err + = -- | Message to display in the error + ErrMsg String + | -- | Pretty print a String that was produced by 'show' + ErrPrettyString String + +-- | Plain message to display, as 'Text' +message :: Text -> Err +message = ErrMsg . Text.unpack + +-- | Plain message to display, as 'String' +messageString :: String -> Err +messageString = ErrMsg + +-- | Any 'Show'able to pretty print +pretty :: Show a => a -> Err +pretty x = ErrPrettyString $ show x + +-- | Pretty print a String that was produced by 'show' +prettyString :: String -> Err +prettyString s = ErrPrettyString s + +-- Prettifying Helpers, mostly stolen from +-- https://hackage.haskell.org/package/hspec-expectations-pretty-diff-0.7.2.5/docs/src/Test.Hspec.Expectations.Pretty.html#prettyColor + +hscolour' :: String -> String +hscolour' = + hscolour (TTYg Ansi16Colour) defaultColourPrefs False False "" False + +color :: Color -> String -> String +color c s = setSGRCode [SetColor Foreground Dull c] ++ s ++ setSGRCode [Reset] diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix index 797beda82eff..87731394fc47 100644 --- a/users/Profpatsch/my-prelude/default.nix +++ b/users/Profpatsch/my-prelude/default.nix @@ -8,6 +8,7 @@ pkgs.haskellPackages.mkDerivation { ./my-prelude.cabal ./MyPrelude.hs ./Label.hs + ./Pretty.hs ]; isLibrary = true; @@ -21,6 +22,9 @@ pkgs.haskellPackages.mkDerivation { pkgs.haskellPackages.validation-selective pkgs.haskellPackages.error + pkgs.haskellPackages.hscolour + pkgs.haskellPackages.nicify-lib + pkgs.haskellPackages.ansi-terminal ]; license = lib.licenses.mit; diff --git a/users/Profpatsch/my-prelude/my-prelude.cabal b/users/Profpatsch/my-prelude/my-prelude.cabal index 508bbba055dc..48e71bb926a3 100644 --- a/users/Profpatsch/my-prelude/my-prelude.cabal +++ b/users/Profpatsch/my-prelude/my-prelude.cabal @@ -8,6 +8,7 @@ library exposed-modules: MyPrelude Label + Pretty -- Modules included in this executable, other than Main. -- other-modules: @@ -26,4 +27,7 @@ library , error , bytestring , mtl + , hscolour + , nicify-lib + , ansi-terminal default-language: Haskell2010 |