{-# OPTIONS_GHC -fno-warn-orphans #-}

{-# LANGUAGE CPP                   #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE UndecidableInstances  #-}

module PlutusPrelude
    ( -- * Reexports from base
      (&)
    , (&&&)
    , (>>>)
    , (<&>)
    , 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'
    , lens
    , (^.)
    , view
    , (.~)
    , set
    , (%~)
    , over
    , (<^>)
    -- * Debugging
    , traceShowId
    , trace
    -- * Reexports from "Control.Composition"
    , (.*)
    -- * Custom functions
    , (<<$>>)
    , (<<*>>)
    , mtraverse
    , foldMapM
    , reoption
    , enumerate
    , tabulateArray
    , (?)
    , ensure
    , asksM
    , timesA
    -- * Pretty-printing
    , Doc
    , ShowPretty (..)
    , Pretty (..)
    , PrettyBy (..)
    , HasPrettyDefaults
    , PrettyDefaultBy
    , PrettyAny (..)
    , Render (..)
    , display
    -- * GHCi
    , printPretty
    -- * Text
    , showText
    , Default (def)
    -- * Lists
    , 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 <^>

-- | A newtype wrapper around @a@ whose point is to provide a 'Show' instance
-- for anything that has a 'Pretty' instance.
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)

-- | Default pretty-printing for the __spine__ of 'Either' (elements are pretty-printed the way
-- @PrettyBy config@ constraints specify it).
instance (PrettyBy config a, PrettyBy config b) => DefaultPrettyBy config (Either a b)

-- | An instance extending the set of types supporting default pretty-printing with 'Either'.
deriving via PrettyCommon (Either a b)
    instance PrettyDefaultBy config (Either a b) => PrettyBy config (Either a b)

-- | Coerce the second argument to the result type of the first one. The motivation for this
-- function is that it's often more annoying to explicitly specify a target type for 'coerce' than
-- to construct an explicit coercion function, so this combinator can be used in cases like that.
-- Plus the code reads better, as it becomes clear what and where gets wrapped/unwrapped.
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 #-}

-- | Same as @\f -> f . coerce@, but does not create any closures and so is completely free.
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 #-}

-- | Same as @\f -> coerce . f@, but does not create any closures and so is completely free.
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
(<*>)

-- | Makes an effectful function ignore its result value and return its input value.
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

-- | Fold a monadic function over a 'Foldable'. The monadic version of 'foldMap'.
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

-- | This function generalizes 'eitherToMaybe', 'eitherToList',
-- 'listToMaybe' and other such functions.
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

-- | Basically a @Data.Functor.Representable@ instance for 'Array'.
-- We can't provide an actual instance because of the @Distributive@ superclass: @Array i@ is not
-- @Distributive@ unless we assume that indices in an array range over the entirety of @i@.
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

-- | @b ? x@ is equal to @pure x@ whenever @b@ holds and is 'empty' otherwise.
(?) :: 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 p x@ is equal to @pure x@ whenever @p x@ holds and is 'empty' otherwise.
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

-- | A monadic version of 'asks'.
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

-- For GHCi to use this properly it needs to be in a registered package, hence
-- why we're naming such a trivial thing.
-- | A command suitable for use in GHCi as an interactive printer.
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

-- | Compose two folds to make them run in parallel. The results are concatenated.
(<^>) :: 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

-- | Zips two lists of the same length together, returning 'Nothing' if they are not
-- the same length.
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

-- | Similar to Maybe's `fromJust`. Returns the `Right` and errors out with the show instance
-- of the `Left`.
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

-- | function recursively applied N times
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

-- | A 'MonadError' version of 'try'.
--
-- TODO: remove when we switch to mtl>=2.3
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 #-}

{- A different 'MonadError' analogue to the 'withExceptT' function.
Modify the value (and possibly the type) of an error in an @ExceptT@-transformed
monad, while stripping the @ExceptT@ layer.

TODO: remove when we switch to mtl>=2.3.1
-}
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