{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- This is a non-exposed internal module.
--
-- This code contains utility function and data structures that are used
-- to improve the efficiency of several instances in the Data.* namespace.
-----------------------------------------------------------------------------
module Data.Functor.Utils where

import Data.Coerce (Coercible, coerce)
import GHC.Base ( Applicative(..), Functor(..), Maybe(..), Monad (..)
                , Monoid(..), Ord(..), Semigroup(..), ($), liftM, otherwise )
import qualified GHC.List as List

-- We don't expose Max and Min because, as Edward Kmett pointed out to me,
-- there are two reasonable ways to define them. One way is to use Maybe, as we
-- do here; the other way is to impose a Bounded constraint on the Monoid
-- instance. We may eventually want to add both versions, but we don't want to
-- trample on anyone's toes by imposing Max = MaxMaybe.

newtype Max a = Max {forall a. Max a -> Maybe a
getMax :: Maybe a}
newtype Min a = Min {forall a. Min a -> Maybe a
getMin :: Maybe a}

-- | @since 4.11.0.0
instance Ord a => Semigroup (Max a) where
    {-# INLINE (<>) #-}
    Max a
m <> :: Max a -> Max a -> Max a
<> Max Maybe a
Nothing = Max a
m
    Max Maybe a
Nothing <> Max a
n = Max a
n
    (Max m :: Maybe a
m@(Just a
x)) <> (Max n :: Maybe a
n@(Just a
y))
      | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
y    = Maybe a -> Max a
forall a. Maybe a -> Max a
Max Maybe a
m
      | Bool
otherwise = Maybe a -> Max a
forall a. Maybe a -> Max a
Max Maybe a
n

-- | @since 4.8.0.0
instance Ord a => Monoid (Max a) where
    mempty :: Max a
mempty = Maybe a -> Max a
forall a. Maybe a -> Max a
Max Maybe a
forall a. Maybe a
Nothing
    -- By default, we would get a lazy right fold. This forces the use of a strict
    -- left fold instead.
    mconcat :: [Max a] -> Max a
mconcat = (Max a -> Max a -> Max a) -> Max a -> [Max a] -> Max a
forall a b. (b -> a -> b) -> b -> [a] -> b
List.foldl' Max a -> Max a -> Max a
forall a. Semigroup a => a -> a -> a
(<>) Max a
forall a. Monoid a => a
mempty
    {-# INLINE mconcat #-}

-- | @since 4.11.0.0
instance Ord a => Semigroup (Min a) where
    {-# INLINE (<>) #-}
    Min a
m <> :: Min a -> Min a -> Min a
<> Min Maybe a
Nothing = Min a
m
    Min Maybe a
Nothing <> Min a
n = Min a
n
    (Min m :: Maybe a
m@(Just a
x)) <> (Min n :: Maybe a
n@(Just a
y))
      | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
y    = Maybe a -> Min a
forall a. Maybe a -> Min a
Min Maybe a
m
      | Bool
otherwise = Maybe a -> Min a
forall a. Maybe a -> Min a
Min Maybe a
n

-- | @since 4.8.0.0
instance Ord a => Monoid (Min a) where
    mempty :: Min a
mempty = Maybe a -> Min a
forall a. Maybe a -> Min a
Min Maybe a
forall a. Maybe a
Nothing
    -- By default, we would get a lazy right fold. This forces the use of a strict
    -- left fold instead.
    mconcat :: [Min a] -> Min a
mconcat = (Min a -> Min a -> Min a) -> Min a -> [Min a] -> Min a
forall a b. (b -> a -> b) -> b -> [a] -> b
List.foldl' Min a -> Min a -> Min a
forall a. Semigroup a => a -> a -> a
(<>) Min a
forall a. Monoid a => a
mempty
    {-# INLINE mconcat #-}

-- left-to-right state-transforming monad
newtype StateL s a = StateL { forall s a. StateL s a -> s -> (s, a)
runStateL :: s -> (s, a) }

-- | @since 4.0
instance Functor (StateL s) where
    fmap :: forall a b. (a -> b) -> StateL s a -> StateL s b
fmap a -> b
f (StateL s -> (s, a)
k) = (s -> (s, b)) -> StateL s b
forall s a. (s -> (s, a)) -> StateL s a
StateL ((s -> (s, b)) -> StateL s b) -> (s -> (s, b)) -> StateL s b
forall a b. (a -> b) -> a -> b
$ \ s
s -> let (s
s', a
v) = s -> (s, a)
k s
s in (s
s', a -> b
f a
v)

-- | @since 4.0
instance Applicative (StateL s) where
    pure :: forall a. a -> StateL s a
pure a
x = (s -> (s, a)) -> StateL s a
forall s a. (s -> (s, a)) -> StateL s a
StateL (\ s
s -> (s
s, a
x))
    StateL s -> (s, a -> b)
kf <*> :: forall a b. StateL s (a -> b) -> StateL s a -> StateL s b
<*> StateL s -> (s, a)
kv = (s -> (s, b)) -> StateL s b
forall s a. (s -> (s, a)) -> StateL s a
StateL ((s -> (s, b)) -> StateL s b) -> (s -> (s, b)) -> StateL s b
forall a b. (a -> b) -> a -> b
$ \ s
s ->
        let (s
s', a -> b
f) = s -> (s, a -> b)
kf s
s
            (s
s'', a
v) = s -> (s, a)
kv s
s'
        in (s
s'', a -> b
f a
v)
    liftA2 :: forall a b c.
(a -> b -> c) -> StateL s a -> StateL s b -> StateL s c
liftA2 a -> b -> c
f (StateL s -> (s, a)
kx) (StateL s -> (s, b)
ky) = (s -> (s, c)) -> StateL s c
forall s a. (s -> (s, a)) -> StateL s a
StateL ((s -> (s, c)) -> StateL s c) -> (s -> (s, c)) -> StateL s c
forall a b. (a -> b) -> a -> b
$ \s
s ->
        let (s
s', a
x) = s -> (s, a)
kx s
s
            (s
s'', b
y) = s -> (s, b)
ky s
s'
        in (s
s'', a -> b -> c
f a
x b
y)

-- right-to-left state-transforming monad
newtype StateR s a = StateR { forall s a. StateR s a -> s -> (s, a)
runStateR :: s -> (s, a) }

-- | @since 4.0
instance Functor (StateR s) where
    fmap :: forall a b. (a -> b) -> StateR s a -> StateR s b
fmap a -> b
f (StateR s -> (s, a)
k) = (s -> (s, b)) -> StateR s b
forall s a. (s -> (s, a)) -> StateR s a
StateR ((s -> (s, b)) -> StateR s b) -> (s -> (s, b)) -> StateR s b
forall a b. (a -> b) -> a -> b
$ \ s
s -> let (s
s', a
v) = s -> (s, a)
k s
s in (s
s', a -> b
f a
v)

-- | @since 4.0
instance Applicative (StateR s) where
    pure :: forall a. a -> StateR s a
pure a
x = (s -> (s, a)) -> StateR s a
forall s a. (s -> (s, a)) -> StateR s a
StateR (\ s
s -> (s
s, a
x))
    StateR s -> (s, a -> b)
kf <*> :: forall a b. StateR s (a -> b) -> StateR s a -> StateR s b
<*> StateR s -> (s, a)
kv = (s -> (s, b)) -> StateR s b
forall s a. (s -> (s, a)) -> StateR s a
StateR ((s -> (s, b)) -> StateR s b) -> (s -> (s, b)) -> StateR s b
forall a b. (a -> b) -> a -> b
$ \ s
s ->
        let (s
s', a
v) = s -> (s, a)
kv s
s
            (s
s'', a -> b
f) = s -> (s, a -> b)
kf s
s'
        in (s
s'', a -> b
f a
v)
    liftA2 :: forall a b c.
(a -> b -> c) -> StateR s a -> StateR s b -> StateR s c
liftA2 a -> b -> c
f (StateR s -> (s, a)
kx) (StateR s -> (s, b)
ky) = (s -> (s, c)) -> StateR s c
forall s a. (s -> (s, a)) -> StateR s a
StateR ((s -> (s, c)) -> StateR s c) -> (s -> (s, c)) -> StateR s c
forall a b. (a -> b) -> a -> b
$ \ s
s ->
        let (s
s', b
y) = s -> (s, b)
ky s
s
            (s
s'', a
x) = s -> (s, a)
kx s
s'
        in (s
s'', a -> b -> c
f a
x b
y)

-- | A state transformer monad parameterized by the state and inner monad.
-- The implementation is copied from the transformers package with the
-- return tuple swapped.
--
-- @since 4.18.0.0
newtype StateT s m a = StateT { forall s (m :: * -> *) a. StateT s m a -> s -> m (s, a)
runStateT :: s -> m (s, a) }

-- | @since 4.18.0.0
instance Monad m => Functor (StateT s m) where
    fmap :: forall a b. (a -> b) -> StateT s m a -> StateT s m b
fmap = (a -> b) -> StateT s m a -> StateT s m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
    {-# INLINE fmap #-}

-- | @since 4.18.0.0
instance Monad m => Applicative (StateT s m) where
    pure :: forall a. a -> StateT s m a
pure a
a = (s -> m (s, a)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateT s m a
StateT ((s -> m (s, a)) -> StateT s m a)
-> (s -> m (s, a)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ \ s
s -> (s, a) -> m (s, a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (s
s, a
a)
    {-# INLINE pure #-}
    StateT s -> m (s, a -> b)
mf <*> :: forall a b. StateT s m (a -> b) -> StateT s m a -> StateT s m b
<*> StateT s -> m (s, a)
mx = (s -> m (s, b)) -> StateT s m b
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateT s m a
StateT ((s -> m (s, b)) -> StateT s m b)
-> (s -> m (s, b)) -> StateT s m b
forall a b. (a -> b) -> a -> b
$ \ s
s -> do
        (s
s', a -> b
f) <- s -> m (s, a -> b)
mf s
s
        (s
s'', a
x) <- s -> m (s, a)
mx s
s'
        (s, b) -> m (s, b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (s
s'', a -> b
f a
x)
    {-# INLINE (<*>) #-}
    StateT s m a
m *> :: forall a b. StateT s m a -> StateT s m b -> StateT s m b
*> StateT s m b
k = StateT s m a
m StateT s m a -> (a -> StateT s m b) -> StateT s m b
forall a b. StateT s m a -> (a -> StateT s m b) -> StateT s m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
_ -> StateT s m b
k
    {-# INLINE (*>) #-}

-- | @since 4.18.0.0
instance (Monad m) => Monad (StateT s m) where
    StateT s m a
m >>= :: forall a b. StateT s m a -> (a -> StateT s m b) -> StateT s m b
>>= a -> StateT s m b
k  = (s -> m (s, b)) -> StateT s m b
forall s (m :: * -> *) a. (s -> m (s, a)) -> StateT s m a
StateT ((s -> m (s, b)) -> StateT s m b)
-> (s -> m (s, b)) -> StateT s m b
forall a b. (a -> b) -> a -> b
$ \ s
s -> do
        (s
s', a
a) <- StateT s m a -> s -> m (s, a)
forall s (m :: * -> *) a. StateT s m a -> s -> m (s, a)
runStateT StateT s m a
m s
s
        StateT s m b -> s -> m (s, b)
forall s (m :: * -> *) a. StateT s m a -> s -> m (s, a)
runStateT (a -> StateT s m b
k a
a) s
s'
    {-# INLINE (>>=) #-}

-- See Note [Function coercion]
(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)
#. :: forall b c a. Coercible b c => (b -> c) -> (a -> b) -> a -> c
(#.) b -> c
_f = (a -> b) -> a -> c
forall a b. Coercible a b => a -> b
coerce
{-# INLINE (#.) #-}

{-
Note [Function coercion]
~~~~~~~~~~~~~~~~~~~~~~~

Several functions here use (#.) instead of (.) to avoid potential efficiency
problems relating to #7542. The problem, in a nutshell:

If N is a newtype constructor, then N x will always have the same
representation as x (something similar applies for a newtype deconstructor).
However, if f is a function,

N . f = \x -> N (f x)

This looks almost the same as f, but the eta expansion lifts it--the lhs could
be _|_, but the rhs never is. This can lead to very inefficient code.  Thus we
steal a technique from Shachaf and Edward Kmett and adapt it to the current
(rather clean) setting. Instead of using  N . f,  we use  N #. f, which is
just

coerce f `asTypeOf` (N . f)

That is, we just *pretend* that f has the right type, and thanks to the safety
of coerce, the type checker guarantees that nothing really goes wrong. We still
have to be a bit careful, though: remember that #. completely ignores the
*value* of its left operand.
-}