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

{-# LANGUAGE DefaultSignatures     #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}

module PlutusPrelude
    ( -- * Reexports from base
      (&)
    , (&&&)
    , (<&>)
    , toList
    , bool
    , first
    , second
    , on
    , isNothing
    , isJust
    , fromMaybe
    , guard
    , foldl'
    , fold
    , for
    , throw
    , join
    , (<=<)
    , (>=>)
    , ($>)
    , fromRight
    , isRight
    , void
    , through
    , coerce
    , 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
    , enumeration
    , tabulateArray
    , (?)
    , ensure
    , asksM
    -- * Pretty-printing
    , Doc
    , ShowPretty (..)
    , Pretty (..)
    , PrettyBy (..)
    , HasPrettyDefaults
    , PrettyDefaultBy
    , PrettyAny (..)
    , Render (..)
    , display
    -- * GHCi
    , printPretty
    -- * Text
    , showText
    ) where

import Control.Applicative (Alternative (..))
import Control.Arrow ((&&&))
import Control.Composition ((.*))
import Control.DeepSeq (NFData)
import Control.Exception (Exception, throw)
import Control.Lens
import Control.Monad.Reader
import Data.Array
import Data.Bifunctor (first, second)
import Data.Bool (bool)
import Data.Coerce (Coercible, coerce)
import Data.Either (fromRight, isRight)
import Data.Foldable (fold, toList)
import Data.Function (on)
import Data.Functor (($>))
import Data.Functor.Compose
import Data.List (foldl')
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Text qualified as T
import Data.Traversable (for)
import Data.Typeable (Typeable)
import Data.Word (Word8)
import Debug.Trace
import GHC.Generics
import GHC.Natural (Natural)
import Prettyprinter
import Text.PrettyBy.Default
import Text.PrettyBy.Internal

infixr 2 ?
infixl 4 <<$>>, <<*>>

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

(<<$>>) :: (Functor f1, Functor f2) => (a -> b) -> f1 (f2 a) -> f1 (f2 b)
<<$>> :: (a -> b) -> f1 (f2 a) -> f1 (f2 b)
(<<$>>) a -> b
f = Compose f1 f2 b -> f1 (f2 b)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose f1 f2 b -> f1 (f2 b))
-> (f1 (f2 a) -> Compose f1 f2 b) -> f1 (f2 a) -> f1 (f2 b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> Compose f1 f2 a -> Compose f1 f2 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Compose f1 f2 a -> Compose f1 f2 b)
-> (f1 (f2 a) -> Compose f1 f2 a) -> f1 (f2 a) -> Compose f1 f2 b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f1 (f2 a) -> Compose f1 f2 a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose

(<<*>>) :: (Applicative f1, Applicative f2) => f1 (f2 (a -> b)) -> f1 (f2 a) -> f1 (f2 b)
f1 (f2 (a -> b))
f <<*>> :: f1 (f2 (a -> b)) -> f1 (f2 a) -> f1 (f2 b)
<<*>> f1 (f2 a)
a = Compose f1 f2 b -> f1 (f2 b)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose f1 f2 b -> f1 (f2 b)) -> Compose f1 f2 b -> f1 (f2 b)
forall a b. (a -> b) -> a -> b
$ f1 (f2 (a -> b)) -> Compose f1 f2 (a -> b)
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose f1 (f2 (a -> b))
f Compose f1 f2 (a -> b) -> Compose f1 f2 a -> Compose f1 f2 b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f1 (f2 a) -> Compose f1 f2 a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose f1 (f2 a)
a

-- | Makes an effectful function ignore its result value and return its input value.
through :: Functor f => (a -> f b) -> (a -> f a)
through :: (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 :: (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)
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 :: (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 (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> (b -> m b) -> b -> m b
step b -> m b
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 (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 :: f a -> g a
reoption = (a -> g a -> g a) -> g a -> f a -> g a
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 (f :: * -> *) a. Applicative f => a -> f a
pure) g a
forall (f :: * -> *) a. Alternative f => f a
empty

enumeration :: (Bounded a, Enum a) => [a]
enumeration :: [a]
enumeration = [a
forall a. Bounded a => a
minBound .. a
forall a. Bounded a => a
maxBound]

-- | 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 :: (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. (Bounded a, Enum a) => [a]
enumeration

newtype PairT b f a = PairT
    { PairT b f a -> f (b, a)
unPairT :: f (b, a)
    }

instance Functor f => Functor (PairT b f) where
    fmap :: (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((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
? :: Bool -> a -> f a
(?) Bool
b a
x = a
x a -> f () -> 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 :: (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 :: (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 (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 :: 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 a ann. Pretty a => a -> Doc ann
pretty

showText :: Show a => a -> T.Text
showText :: 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