{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
module PlutusPrelude
(
(&)
, (&&&)
, (>>>)
, (<&>)
, toList
, first
, second
, on
, isNothing
, isJust
, fromMaybe
, guard
, foldl'
, for_
, traverse_
, fold
, for
, throw
, join
, (<=<)
, (>=>)
, ($>)
, fromRight
, isRight
, isLeft
, void
, through
, coerce
, coerceVia
, coerceArg
, coerceRes
, Generic
, NFData
, Natural
, NonEmpty (..)
, Word8
, Alternative (..)
, Exception
, PairT (..)
, Coercible
, Typeable
, Lens'
, lens
, (^.)
, view
, (.~)
, set
, (%~)
, over
, (<^>)
, traceShowId
, trace
, (.*)
, (<<$>>)
, (<<*>>)
, mtraverse
, foldMapM
, reoption
, enumerate
, tabulateArray
, (?)
, ensure
, asksM
, timesA
, Doc
, ShowPretty (..)
, Pretty (..)
, PrettyBy (..)
, HasPrettyDefaults
, PrettyDefaultBy
, PrettyAny (..)
, Render (..)
, display
, printPretty
, showText
, Default (def)
, zipExact
, allSame
, distinct
, unsafeFromRight
, tryError
, modifyError
, lowerInitialChar
) where
import Control.Applicative
import Control.Arrow ((&&&), (>>>))
import Control.Composition ((.*))
import Control.DeepSeq (NFData)
import Control.Exception (Exception, throw)
import Control.Lens (Fold, Lens', ala, lens, over, set, view, (%~), (&), (.~), (<&>), (^.))
import Control.Monad
import Control.Monad.Except (ExceptT, MonadError, catchError, runExceptT, throwError)
import Control.Monad.Reader (MonadReader, ask)
import Data.Array (Array, Ix, listArray)
import Data.Bifunctor (first, second)
import Data.Char (toLower)
import Data.Coerce (Coercible, coerce)
import Data.Default.Class
import Data.Either (fromRight, isLeft, isRight)
import Data.Foldable (fold, for_, toList, traverse_)
import Data.Function (on)
import Data.Functor (($>))
#if ! MIN_VERSION_base(4,20,0)
import Data.List (foldl')
#endif
import Data.List.Extra (enumerate)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Semigroup (Endo (..), stimes)
import Data.Text qualified as T
import Data.Traversable (for)
import Data.Typeable (Typeable)
import Data.Word (Word8)
import Debug.Trace (trace, traceShowId)
import GHC.Generics (Generic)
import GHC.Natural (Natural)
import Prettyprinter
import Text.PrettyBy.Default
import Text.PrettyBy.Internal
infixr 2 ?
infixl 4 <<$>>, <<*>>
infixr 6 <^>
newtype ShowPretty a = ShowPretty
{ forall a. ShowPretty a -> a
unShowPretty :: a
} deriving stock (ShowPretty a -> ShowPretty a -> Bool
(ShowPretty a -> ShowPretty a -> Bool)
-> (ShowPretty a -> ShowPretty a -> Bool) -> Eq (ShowPretty a)
forall a. Eq a => ShowPretty a -> ShowPretty a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => ShowPretty a -> ShowPretty a -> Bool
== :: ShowPretty a -> ShowPretty a -> Bool
$c/= :: forall a. Eq a => ShowPretty a -> ShowPretty a -> Bool
/= :: ShowPretty a -> ShowPretty a -> Bool
Eq)
instance Pretty a => Show (ShowPretty a) where
show :: ShowPretty a -> String
show = a -> String
forall str a. (Pretty a, Render str) => a -> str
display (a -> String) -> (ShowPretty a -> a) -> ShowPretty a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowPretty a -> a
forall a. ShowPretty a -> a
unShowPretty
instance (Pretty a, Pretty b) => Pretty (Either a b) where
pretty :: forall ann. Either a b -> Doc ann
pretty (Left a
x) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"Left" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
x)
pretty (Right b
y) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann
"Right" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> b -> Doc ann
forall ann. b -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty b
y)
instance (PrettyBy config a, PrettyBy config b) => DefaultPrettyBy config (Either a b)
deriving via PrettyCommon (Either a b)
instance PrettyDefaultBy config (Either a b) => PrettyBy config (Either a b)
coerceVia :: Coercible a b => (a -> b) -> a -> b
coerceVia :: forall a b. Coercible a b => (a -> b) -> a -> b
coerceVia a -> b
_ = a -> b
forall a b. Coercible a b => a -> b
coerce
{-# INLINE coerceVia #-}
coerceArg :: Coercible a b => (a -> s) -> b -> s
coerceArg :: forall a b s. Coercible a b => (a -> s) -> b -> s
coerceArg = (a -> s) -> b -> s
forall a b. Coercible a b => a -> b
coerce
{-# INLINE coerceArg #-}
coerceRes :: Coercible s t => (a -> s) -> a -> t
coerceRes :: forall s t a. Coercible s t => (a -> s) -> a -> t
coerceRes = (a -> s) -> a -> t
forall a b. Coercible a b => a -> b
coerce
{-# INLINE coerceRes #-}
(<<$>>) :: (Functor f1, Functor f2) => (a -> b) -> f1 (f2 a) -> f1 (f2 b)
<<$>> :: forall (f1 :: * -> *) (f2 :: * -> *) a b.
(Functor f1, Functor f2) =>
(a -> b) -> f1 (f2 a) -> f1 (f2 b)
(<<$>>) = (f2 a -> f2 b) -> f1 (f2 a) -> f1 (f2 b)
forall a b. (a -> b) -> f1 a -> f1 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f2 a -> f2 b) -> f1 (f2 a) -> f1 (f2 b))
-> ((a -> b) -> f2 a -> f2 b) -> (a -> b) -> f1 (f2 a) -> f1 (f2 b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> f2 a -> f2 b
forall a b. (a -> b) -> f2 a -> f2 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
(<<*>>) :: (Applicative f1, Applicative f2) => f1 (f2 (a -> b)) -> f1 (f2 a) -> f1 (f2 b)
<<*>> :: forall (f1 :: * -> *) (f2 :: * -> *) a b.
(Applicative f1, Applicative f2) =>
f1 (f2 (a -> b)) -> f1 (f2 a) -> f1 (f2 b)
(<<*>>) = (f2 (a -> b) -> f2 a -> f2 b)
-> f1 (f2 (a -> b)) -> f1 (f2 a) -> f1 (f2 b)
forall a b c. (a -> b -> c) -> f1 a -> f1 b -> f1 c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 f2 (a -> b) -> f2 a -> f2 b
forall a b. f2 (a -> b) -> f2 a -> f2 b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
through :: Functor f => (a -> f b) -> (a -> f a)
through :: forall (f :: * -> *) a b. Functor f => (a -> f b) -> a -> f a
through a -> f b
f a
x = a -> f b
f a
x f b -> a -> f a
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a
x
mtraverse :: (Monad m, Traversable m, Applicative f) => (a -> f (m b)) -> m a -> f (m b)
mtraverse :: forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable m, Applicative f) =>
(a -> f (m b)) -> m a -> f (m b)
mtraverse a -> f (m b)
f m a
a = m (m b) -> m b
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m b) -> m b) -> f (m (m b)) -> f (m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f (m b)) -> m a -> f (m (m b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> m a -> f (m b)
traverse a -> f (m b)
f m a
a
foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b
foldMapM :: forall (f :: * -> *) (m :: * -> *) b a.
(Foldable f, Monad m, Monoid b) =>
(a -> m b) -> f a -> m b
foldMapM a -> m b
f f a
xs = (a -> (b -> m b) -> b -> m b) -> (b -> m b) -> f a -> b -> m b
forall a b. (a -> b -> b) -> b -> f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> (b -> m b) -> b -> m b
forall {b}. a -> (b -> m b) -> b -> m b
step b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return f a
xs b
forall a. Monoid a => a
mempty where
step :: a -> (b -> m b) -> b -> m b
step a
x b -> m b
r b
z = a -> m b
f a
x m b -> (b -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
y -> b -> m b
r (b -> m b) -> b -> m b
forall a b. (a -> b) -> a -> b
$! b
z b -> b -> b
forall a. Monoid a => a -> a -> a
`mappend` b
y
reoption :: (Foldable f, Alternative g) => f a -> g a
reoption :: forall (f :: * -> *) (g :: * -> *) a.
(Foldable f, Alternative g) =>
f a -> g a
reoption = (a -> g a -> g a) -> g a -> f a -> g a
forall a b. (a -> b -> b) -> b -> f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (g a -> g a -> g a
forall a b. a -> b -> a
const (g a -> g a -> g a) -> (a -> g a) -> a -> g a -> g a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> g a
forall a. a -> g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) g a
forall a. g a
forall (f :: * -> *) a. Alternative f => f a
empty
tabulateArray :: (Bounded i, Enum i, Ix i) => (i -> a) -> Array i a
tabulateArray :: forall i a. (Bounded i, Enum i, Ix i) => (i -> a) -> Array i a
tabulateArray i -> a
f = (i, i) -> [a] -> Array i a
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (i
forall a. Bounded a => a
minBound, i
forall a. Bounded a => a
maxBound) ([a] -> Array i a) -> [a] -> Array i a
forall a b. (a -> b) -> a -> b
$ (i -> a) -> [i] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map i -> a
f [i]
forall a. (Enum a, Bounded a) => [a]
enumerate
newtype PairT b f a = PairT
{ forall b (f :: * -> *) a. PairT b f a -> f (b, a)
unPairT :: f (b, a)
}
instance Functor f => Functor (PairT b f) where
fmap :: forall a b. (a -> b) -> PairT b f a -> PairT b f b
fmap a -> b
f (PairT f (b, a)
p) = f (b, b) -> PairT b f b
forall b (f :: * -> *) a. f (b, a) -> PairT b f a
PairT (f (b, b) -> PairT b f b) -> f (b, b) -> PairT b f b
forall a b. (a -> b) -> a -> b
$ ((b, a) -> (b, b)) -> f (b, a) -> f (b, b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (b, a) -> (b, b)
forall a b. (a -> b) -> (b, a) -> (b, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) f (b, a)
p
(?) :: Alternative f => Bool -> a -> f a
? :: forall (f :: * -> *) a. Alternative f => Bool -> a -> f a
(?) Bool
b a
x = a
x a -> f () -> f a
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> f ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
b
ensure :: Alternative f => (a -> Bool) -> a -> f a
ensure :: forall (f :: * -> *) a. Alternative f => (a -> Bool) -> a -> f a
ensure a -> Bool
p a
x = a -> Bool
p a
x Bool -> a -> f a
forall (f :: * -> *) a. Alternative f => Bool -> a -> f a
? a
x
asksM :: MonadReader r m => (r -> m a) -> m a
asksM :: forall r (m :: * -> *) a. MonadReader r m => (r -> m a) -> m a
asksM r -> m a
k = m r
forall r (m :: * -> *). MonadReader r m => m r
ask m r -> (r -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= r -> m a
k
printPretty :: Pretty a => a -> IO ()
printPretty :: forall a. Pretty a => a -> IO ()
printPretty = Doc Any -> IO ()
forall a. Show a => a -> IO ()
print (Doc Any -> IO ()) -> (a -> Doc Any) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Any
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty
showText :: Show a => a -> T.Text
showText :: forall a. Show a => a -> Text
showText = String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show
(<^>) :: Fold s a -> Fold s a -> Fold s a
(Fold s a
f1 <^> :: forall s a. Fold s a -> Fold s a -> Fold s a
<^> Fold s a
f2) a -> f a
g s
s = (a -> f a) -> s -> f s
Fold s a
f1 a -> f a
g s
s f s -> f s -> f s
forall a b. f a -> f b -> f b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (a -> f a) -> s -> f s
Fold s a
f2 a -> f a
g s
s
zipExact :: [a] -> [b] -> Maybe [(a,b)]
zipExact :: forall a b. [a] -> [b] -> Maybe [(a, b)]
zipExact [] [] = [(a, b)] -> Maybe [(a, b)]
forall a. a -> Maybe a
Just []
zipExact (a
a:[a]
as) (b
b:[b]
bs) = (:) (a
a, b
b) ([(a, b)] -> [(a, b)]) -> Maybe [(a, b)] -> Maybe [(a, b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> [b] -> Maybe [(a, b)]
forall a b. [a] -> [b] -> Maybe [(a, b)]
zipExact [a]
as [b]
bs
zipExact [a]
_ [b]
_ = Maybe [(a, b)]
forall a. Maybe a
Nothing
unsafeFromRight :: (Show e) => Either e a -> a
unsafeFromRight :: forall e a. Show e => Either e a -> a
unsafeFromRight (Right a
a) = a
a
unsafeFromRight (Left e
e) = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ e -> String
forall a. Show a => a -> String
show e
e
timesA :: Natural -> (a -> a) -> a -> a
timesA :: forall a. Natural -> (a -> a) -> a -> a
timesA = (Unwrapped (Endo a) -> Endo a)
-> ((Unwrapped (Endo a) -> Endo a) -> (a -> a) -> Endo a)
-> (a -> a)
-> Unwrapped (Endo a)
forall (f :: * -> *) s t.
(Functor f, Rewrapping s t) =>
(Unwrapped s -> s)
-> ((Unwrapped t -> t) -> f s) -> f (Unwrapped s)
ala Unwrapped (Endo a) -> Endo a
(a -> a) -> Endo a
forall a. (a -> a) -> Endo a
Endo ((((a -> a) -> Endo a) -> (a -> a) -> Endo a)
-> (a -> a) -> a -> a)
-> (Natural -> ((a -> a) -> Endo a) -> (a -> a) -> Endo a)
-> Natural
-> (a -> a)
-> a
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> ((a -> a) -> Endo a) -> (a -> a) -> Endo a
forall b.
Integral b =>
b -> ((a -> a) -> Endo a) -> (a -> a) -> Endo a
forall a b. (Semigroup a, Integral b) => b -> a -> a
stimes
tryError :: MonadError e m => m a -> m (Either e a)
tryError :: forall e (m :: * -> *) a. MonadError e m => m a -> m (Either e a)
tryError m a
a = (a -> Either e a
forall a b. b -> Either a b
Right (a -> Either e a) -> m a -> m (Either e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
a) m (Either e a) -> (e -> m (Either e a)) -> m (Either e a)
forall a. m a -> (e -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (Either e a -> m (Either e a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> m (Either e a))
-> (e -> Either e a) -> e -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e a
forall a b. a -> Either a b
Left)
{-# INLINE tryError #-}
modifyError :: MonadError e' m => (e -> e') -> ExceptT e m a -> m a
modifyError :: forall e' (m :: * -> *) e a.
MonadError e' m =>
(e -> e') -> ExceptT e m a -> m a
modifyError e -> e'
f ExceptT e m a
m = ExceptT e m a -> m (Either e a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e m a
m m (Either e a) -> (Either e a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (e -> m a) -> (a -> m a) -> Either e a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (e' -> m a
forall a. e' -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (e' -> m a) -> (e -> e') -> e -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> e'
f) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
allSame :: Eq a => [a] -> Bool
allSame :: forall a. Eq a => [a] -> Bool
allSame [] = Bool
True
allSame (a
x:[a]
xs) = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==) [a]
xs
distinct :: Eq a => [a] -> Bool
distinct :: forall a. Eq a => [a] -> Bool
distinct = Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall a. Eq a => [a] -> Bool
allSame
lowerInitialChar :: String -> String
lowerInitialChar :: ShowS
lowerInitialChar [] = []
lowerInitialChar (Char
c:String
cs) = Char -> Char
toLower Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
cs