{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.Isolated
-- Copyright   :  (C) 2008 Edward Kmett, (C) 2024 Koji Miyazato
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Koji Miyazato <viercc@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
module Control.Monad.Isolated(
  -- * Impure part isolated from a Monad
  Isolated(..),

  -- * (Re)Unite a Monad from pure and impure parts
  Unite(..),
  hoistUnite,
) where

import Data.Functor.Bind
import Data.Semigroup.Traversable
import Data.Semigroup.Foldable
import Data.Bifunctor (Bifunctor(..))
import Data.Proxy
import Control.Applicative (WrappedMonad(..))

newtype Unite f a = Unite { forall (f :: * -> *) a. Unite f a -> Either a (f a)
runUnite :: Either a (f a) }
  deriving (Int -> Unite f a -> ShowS
[Unite f a] -> ShowS
Unite f a -> String
(Int -> Unite f a -> ShowS)
-> (Unite f a -> String)
-> ([Unite f a] -> ShowS)
-> Show (Unite f a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (f :: * -> *) a.
(Show a, Show (f a)) =>
Int -> Unite f a -> ShowS
forall (f :: * -> *) a.
(Show a, Show (f a)) =>
[Unite f a] -> ShowS
forall (f :: * -> *) a. (Show a, Show (f a)) => Unite f a -> String
$cshowsPrec :: forall (f :: * -> *) a.
(Show a, Show (f a)) =>
Int -> Unite f a -> ShowS
showsPrec :: Int -> Unite f a -> ShowS
$cshow :: forall (f :: * -> *) a. (Show a, Show (f a)) => Unite f a -> String
show :: Unite f a -> String
$cshowList :: forall (f :: * -> *) a.
(Show a, Show (f a)) =>
[Unite f a] -> ShowS
showList :: [Unite f a] -> ShowS
Show, ReadPrec [Unite f a]
ReadPrec (Unite f a)
Int -> ReadS (Unite f a)
ReadS [Unite f a]
(Int -> ReadS (Unite f a))
-> ReadS [Unite f a]
-> ReadPrec (Unite f a)
-> ReadPrec [Unite f a]
-> Read (Unite f a)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall (f :: * -> *) a.
(Read a, Read (f a)) =>
ReadPrec [Unite f a]
forall (f :: * -> *) a.
(Read a, Read (f a)) =>
ReadPrec (Unite f a)
forall (f :: * -> *) a.
(Read a, Read (f a)) =>
Int -> ReadS (Unite f a)
forall (f :: * -> *) a. (Read a, Read (f a)) => ReadS [Unite f a]
$creadsPrec :: forall (f :: * -> *) a.
(Read a, Read (f a)) =>
Int -> ReadS (Unite f a)
readsPrec :: Int -> ReadS (Unite f a)
$creadList :: forall (f :: * -> *) a. (Read a, Read (f a)) => ReadS [Unite f a]
readList :: ReadS [Unite f a]
$creadPrec :: forall (f :: * -> *) a.
(Read a, Read (f a)) =>
ReadPrec (Unite f a)
readPrec :: ReadPrec (Unite f a)
$creadListPrec :: forall (f :: * -> *) a.
(Read a, Read (f a)) =>
ReadPrec [Unite f a]
readListPrec :: ReadPrec [Unite f a]
Read, Unite f a -> Unite f a -> Bool
(Unite f a -> Unite f a -> Bool)
-> (Unite f a -> Unite f a -> Bool) -> Eq (Unite f a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (f :: * -> *) a.
(Eq a, Eq (f a)) =>
Unite f a -> Unite f a -> Bool
$c== :: forall (f :: * -> *) a.
(Eq a, Eq (f a)) =>
Unite f a -> Unite f a -> Bool
== :: Unite f a -> Unite f a -> Bool
$c/= :: forall (f :: * -> *) a.
(Eq a, Eq (f a)) =>
Unite f a -> Unite f a -> Bool
/= :: Unite f a -> Unite f a -> Bool
Eq, Eq (Unite f a)
Eq (Unite f a) =>
(Unite f a -> Unite f a -> Ordering)
-> (Unite f a -> Unite f a -> Bool)
-> (Unite f a -> Unite f a -> Bool)
-> (Unite f a -> Unite f a -> Bool)
-> (Unite f a -> Unite f a -> Bool)
-> (Unite f a -> Unite f a -> Unite f a)
-> (Unite f a -> Unite f a -> Unite f a)
-> Ord (Unite f a)
Unite f a -> Unite f a -> Bool
Unite f a -> Unite f a -> Ordering
Unite f a -> Unite f a -> Unite f a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (f :: * -> *) a. (Ord a, Ord (f a)) => Eq (Unite f a)
forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
Unite f a -> Unite f a -> Bool
forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
Unite f a -> Unite f a -> Ordering
forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
Unite f a -> Unite f a -> Unite f a
$ccompare :: forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
Unite f a -> Unite f a -> Ordering
compare :: Unite f a -> Unite f a -> Ordering
$c< :: forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
Unite f a -> Unite f a -> Bool
< :: Unite f a -> Unite f a -> Bool
$c<= :: forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
Unite f a -> Unite f a -> Bool
<= :: Unite f a -> Unite f a -> Bool
$c> :: forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
Unite f a -> Unite f a -> Bool
> :: Unite f a -> Unite f a -> Bool
$c>= :: forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
Unite f a -> Unite f a -> Bool
>= :: Unite f a -> Unite f a -> Bool
$cmax :: forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
Unite f a -> Unite f a -> Unite f a
max :: Unite f a -> Unite f a -> Unite f a
$cmin :: forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
Unite f a -> Unite f a -> Unite f a
min :: Unite f a -> Unite f a -> Unite f a
Ord)

hoistUnite :: (forall a. f a -> g a) -> Unite f b -> Unite g b
hoistUnite :: forall (f :: * -> *) (g :: * -> *) b.
(forall a. f a -> g a) -> Unite f b -> Unite g b
hoistUnite forall a. f a -> g a
fg = Either b (g b) -> Unite g b
forall (f :: * -> *) a. Either a (f a) -> Unite f a
Unite (Either b (g b) -> Unite g b)
-> (Unite f b -> Either b (g b)) -> Unite f b -> Unite g b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f b -> g b) -> Either b (f b) -> Either b (g b)
forall a b. (a -> b) -> Either b a -> Either b b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f b -> g b
forall a. f a -> g a
fg (Either b (f b) -> Either b (g b))
-> (Unite f b -> Either b (f b)) -> Unite f b -> Either b (g b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unite f b -> Either b (f b)
forall (f :: * -> *) a. Unite f a -> Either a (f a)
runUnite

instance (Functor g) => Functor (Unite g) where
  fmap :: forall a b. (a -> b) -> Unite g a -> Unite g b
fmap a -> b
f = Either b (g b) -> Unite g b
forall (f :: * -> *) a. Either a (f a) -> Unite f a
Unite (Either b (g b) -> Unite g b)
-> (Unite g a -> Either b (g b)) -> Unite g a -> Unite g b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> (g a -> g b) -> Either a (g a) -> Either b (g b)
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f ((a -> b) -> g a -> g b
forall a b. (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (Either a (g a) -> Either b (g b))
-> (Unite g a -> Either a (g a)) -> Unite g a -> Either b (g b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unite g a -> Either a (g a)
forall (f :: * -> *) a. Unite f a -> Either a (f a)
runUnite

instance (Foldable g) => Foldable (Unite g) where
  foldMap :: forall m a. Monoid m => (a -> m) -> Unite g a -> m
foldMap a -> m
f = (a -> m) -> (g a -> m) -> Either a (g a) -> m
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> m
f ((a -> m) -> g a -> m
forall m a. Monoid m => (a -> m) -> g a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) (Either a (g a) -> m)
-> (Unite g a -> Either a (g a)) -> Unite g a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unite g a -> Either a (g a)
forall (f :: * -> *) a. Unite f a -> Either a (f a)
runUnite

instance (Foldable1 g) => Foldable1 (Unite g) where
  foldMap1 :: forall m a. Semigroup m => (a -> m) -> Unite g a -> m
foldMap1 a -> m
f = (a -> m) -> (g a -> m) -> Either a (g a) -> m
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> m
f ((a -> m) -> g a -> m
forall m a. Semigroup m => (a -> m) -> g a -> m
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 a -> m
f) (Either a (g a) -> m)
-> (Unite g a -> Either a (g a)) -> Unite g a -> m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unite g a -> Either a (g a)
forall (f :: * -> *) a. Unite f a -> Either a (f a)
runUnite

instance (Traversable g) => Traversable (Unite g) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Unite g a -> f (Unite g b)
traverse a -> f b
f = (Either b (g b) -> Unite g b)
-> f (Either b (g b)) -> f (Unite g b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either b (g b) -> Unite g b
forall (f :: * -> *) a. Either a (f a) -> Unite f a
Unite (f (Either b (g b)) -> f (Unite g b))
-> (Unite g a -> f (Either b (g b))) -> Unite g a -> f (Unite g b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f (Either b (g b)))
-> (g a -> f (Either b (g b)))
-> Either a (g a)
-> f (Either b (g b))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((b -> Either b (g b)) -> f b -> f (Either b (g b))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either b (g b)
forall a b. a -> Either a b
Left (f b -> f (Either b (g b)))
-> (a -> f b) -> a -> f (Either b (g b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f) ((g b -> Either b (g b)) -> f (g b) -> f (Either b (g b))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap g b -> Either b (g b)
forall a b. b -> Either a b
Right (f (g b) -> f (Either b (g b)))
-> (g a -> f (g b)) -> g a -> f (Either b (g b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> g a -> f (g 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) -> g a -> f (g b)
traverse a -> f b
f) (Either a (g a) -> f (Either b (g b)))
-> (Unite g a -> Either a (g a)) -> Unite g a -> f (Either b (g b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unite g a -> Either a (g a)
forall (f :: * -> *) a. Unite f a -> Either a (f a)
runUnite

instance (Traversable1 g) => Traversable1 (Unite g) where
  traverse1 :: forall (f :: * -> *) a b.
Apply f =>
(a -> f b) -> Unite g a -> f (Unite g b)
traverse1 a -> f b
f = (Either b (g b) -> Unite g b)
-> f (Either b (g b)) -> f (Unite g b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either b (g b) -> Unite g b
forall (f :: * -> *) a. Either a (f a) -> Unite f a
Unite (f (Either b (g b)) -> f (Unite g b))
-> (Unite g a -> f (Either b (g b))) -> Unite g a -> f (Unite g b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f (Either b (g b)))
-> (g a -> f (Either b (g b)))
-> Either a (g a)
-> f (Either b (g b))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((b -> Either b (g b)) -> f b -> f (Either b (g b))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either b (g b)
forall a b. a -> Either a b
Left (f b -> f (Either b (g b)))
-> (a -> f b) -> a -> f (Either b (g b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> f b
f) ((g b -> Either b (g b)) -> f (g b) -> f (Either b (g b))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap g b -> Either b (g b)
forall a b. b -> Either a b
Right (f (g b) -> f (Either b (g b)))
-> (g a -> f (g b)) -> g a -> f (Either b (g b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f b) -> g a -> f (g b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable1 t, Apply f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b. Apply f => (a -> f b) -> g a -> f (g b)
traverse1 a -> f b
f) (Either a (g a) -> f (Either b (g b)))
-> (Unite g a -> Either a (g a)) -> Unite g a -> f (Either b (g b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unite g a -> Either a (g a)
forall (f :: * -> *) a. Unite f a -> Either a (f a)
runUnite

-- | @Isolated m0@ is a @Functor@ which can be thought of as an impure part of a @Monad@.
-- 
-- ==== Examples
-- 
-- - 'Proxy' is @Isolated@ by being same to the 'Nothing' part of the 'Maybe' monad.
--
-- - 'Data.List.NotOne.NotOne' is @Isolated@ by being the list monad ('[]') minus singleton lists,
--   the 'pure' part of the list monad.
--
-- ==== Non-example
--
-- Not every @Monad@ can be isolated its pure and impure parts as the sum of functors.
-- For example, the reader monad cannot be written as a sum of two functors.
--
-- ==== Laws
-- 
-- 'impureBind' must be implemented so that the @Monad (Unite m0)@ instance derived from
-- it is lawful.
-- 
-- @
-- return a = Unite (Left a)
-- 
-- Unite (Left a) >>= k = k a
-- Unite (Right ma) >>= k = ma \`impureBind\` k
-- @
-- 
-- Translating the @Monad@ laws on @Unite m0@ in terms of @impureBind@,
-- the following equations are the @Isolated@ laws on its own.
--
-- - (Right identity)
--
--     @
--     ma \`impureBind\` Unite . Left === Unite (Right ma)
--     @
--
-- - (Associativity)
--
--     @
--     (ma \`impureBind\` f) \`impureBind\` g === ma `impureBind` \a -> either g (\`impureBind\` g) (runUnite fa)
--     @
class Functor m0 => Isolated m0 where
  impureBind :: m0 a -> (a -> Unite m0 b) -> Unite m0 b

infixl 1 `impureBind`

instance Isolated m0 => Apply (Unite m0) where
  <.> :: forall a b. Unite m0 (a -> b) -> Unite m0 a -> Unite m0 b
(<.>) = Unite m0 (a -> b) -> Unite m0 a -> Unite m0 b
forall (f :: * -> *) a b. Bind f => f (a -> b) -> f a -> f b
apDefault

instance Isolated m0 => Applicative (Unite m0) where
  pure :: forall a. a -> Unite m0 a
pure = Either a (m0 a) -> Unite m0 a
forall (f :: * -> *) a. Either a (f a) -> Unite f a
Unite (Either a (m0 a) -> Unite m0 a)
-> (a -> Either a (m0 a)) -> a -> Unite m0 a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a (m0 a)
forall a b. a -> Either a b
Left
  <*> :: forall a b. Unite m0 (a -> b) -> Unite m0 a -> Unite m0 b
(<*>) = Unite m0 (a -> b) -> Unite m0 a -> Unite m0 b
forall a b. Unite m0 (a -> b) -> Unite m0 a -> Unite m0 b
forall (f :: * -> *) a b. Apply f => f (a -> b) -> f a -> f b
(<.>)

instance Isolated m0 => Bind (Unite m0) where
  Unite (Left a
a) >>- :: forall a b. Unite m0 a -> (a -> Unite m0 b) -> Unite m0 b
>>- a -> Unite m0 b
k = a -> Unite m0 b
k a
a
  Unite (Right m0 a
ma) >>- a -> Unite m0 b
k = m0 a
ma m0 a -> (a -> Unite m0 b) -> Unite m0 b
forall a b. m0 a -> (a -> Unite m0 b) -> Unite m0 b
forall (m0 :: * -> *) a b.
Isolated m0 =>
m0 a -> (a -> Unite m0 b) -> Unite m0 b
`impureBind` a -> Unite m0 b
k

instance Isolated m0 => Monad (Unite m0) where
  >>= :: forall a b. Unite m0 a -> (a -> Unite m0 b) -> Unite m0 b
(>>=) = Unite m0 a -> (a -> Unite m0 b) -> Unite m0 b
forall a b. Unite m0 a -> (a -> Unite m0 b) -> Unite m0 b
forall (m :: * -> *) a b. Bind m => m a -> (a -> m b) -> m b
(>>-)

instance Isolated Proxy where
  Proxy a
_ impureBind :: forall a b. Proxy a -> (a -> Unite Proxy b) -> Unite Proxy b
`impureBind` a -> Unite Proxy b
_ = Either b (Proxy b) -> Unite Proxy b
forall (f :: * -> *) a. Either a (f a) -> Unite f a
Unite (Proxy b -> Either b (Proxy b)
forall a b. b -> Either a b
Right Proxy b
forall {k} (t :: k). Proxy t
Proxy)

instance Semigroup s => Isolated ((,) s) where
  (s
s, a
a) impureBind :: forall a b. (s, a) -> (a -> Unite ((,) s) b) -> Unite ((,) s) b
`impureBind` a -> Unite ((,) s) b
k = case Unite ((,) s) b -> Either b (s, b)
forall (f :: * -> *) a. Unite f a -> Either a (f a)
runUnite (a -> Unite ((,) s) b
k a
a) of
    Left b
b -> Either b (s, b) -> Unite ((,) s) b
forall (f :: * -> *) a. Either a (f a) -> Unite f a
Unite ((s, b) -> Either b (s, b)
forall a b. b -> Either a b
Right (s
s, b
b))
    Right (s
s', b
b) -> Either b (s, b) -> Unite ((,) s) b
forall (f :: * -> *) a. Either a (f a) -> Unite f a
Unite ((s, b) -> Either b (s, b)
forall a b. b -> Either a b
Right (s
s s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
s', b
b))

instance Monad m => Isolated (WrappedMonad m) where
  WrapMonad m a
ma impureBind :: forall a b.
WrappedMonad m a
-> (a -> Unite (WrappedMonad m) b) -> Unite (WrappedMonad m) b
`impureBind` a -> Unite (WrappedMonad m) b
k = Either b (WrappedMonad m b) -> Unite (WrappedMonad m) b
forall (f :: * -> *) a. Either a (f a) -> Unite f a
Unite (Either b (WrappedMonad m b) -> Unite (WrappedMonad m) b)
-> (m b -> Either b (WrappedMonad m b))
-> m b
-> Unite (WrappedMonad m) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrappedMonad m b -> Either b (WrappedMonad m b)
forall a b. b -> Either a b
Right (WrappedMonad m b -> Either b (WrappedMonad m b))
-> (m b -> WrappedMonad m b) -> m b -> Either b (WrappedMonad m b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m b -> WrappedMonad m b
forall (m :: * -> *) a. m a -> WrappedMonad m a
WrapMonad (m b -> Unite (WrappedMonad m) b)
-> m b -> Unite (WrappedMonad m) b
forall a b. (a -> b) -> a -> b
$ m a
ma m a -> (a -> 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
>>= \a
a ->
    case Unite (WrappedMonad m) b -> Either b (WrappedMonad m b)
forall (f :: * -> *) a. Unite f a -> Either a (f a)
runUnite (a -> Unite (WrappedMonad m) b
k a
a) of
      Left b
b -> b -> m b
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b
      Right (WrapMonad m b
mb) -> m b
mb