{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# language Safe #-}
-- |
-- Module       : Control.Monad.Trans.Can
-- Copyright    : (c) 2020-2021 Emily Pillmore
-- License      : BSD-3-Clause
--
-- Maintainer   : Emily Pillmore <emilypi@cohomolo.gy>
-- Stability    : Experimental
-- Portability  : Non-portable
--
-- This module contains utilities for the monad transformer
-- for the pointed product.
--
module Control.Monad.Trans.Can
( -- * Monad Transformer
  CanT(..)
  -- ** Combinators
, mapCanT
) where


import Data.Can
import Control.Applicative (liftA2)
import Control.Monad.Writer
import Control.Monad.Reader
import Control.Monad.State.Class
import Control.Monad.Except
import Control.Monad.RWS

-- | A monad transformer for the pointed product,
-- parameterized by:
--
--   * @a@ - the value on the left
--   * @b@ - the value on the right
--   * @m@ - The monad over a pointed product (see: 'Can').
--
-- This monad transformer is similar to 'TheseT',
-- except with the possibility of an empty unital value.
--
newtype CanT a m b = CanT { CanT a m b -> m (Can a b)
runCanT :: m (Can a b) }

-- | Map both the left and right values and output of a computation using
-- the given function.
--
-- * @'runCanT' ('mapCanT' f m) = f . 'runCanT' m@
--
mapCanT :: (m (Can a b) -> n (Can c d)) -> CanT a m b -> CanT c n d
mapCanT :: (m (Can a b) -> n (Can c d)) -> CanT a m b -> CanT c n d
mapCanT f :: m (Can a b) -> n (Can c d)
f = n (Can c d) -> CanT c n d
forall a (m :: * -> *) b. m (Can a b) -> CanT a m b
CanT (n (Can c d) -> CanT c n d)
-> (CanT a m b -> n (Can c d)) -> CanT a m b -> CanT c n d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Can a b) -> n (Can c d)
f (m (Can a b) -> n (Can c d))
-> (CanT a m b -> m (Can a b)) -> CanT a m b -> n (Can c d)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CanT a m b -> m (Can a b)
forall a (m :: * -> *) b. CanT a m b -> m (Can a b)
runCanT

instance Functor f => Functor (CanT a f) where
  fmap :: (a -> b) -> CanT a f a -> CanT a f b
fmap f :: a -> b
f = f (Can a b) -> CanT a f b
forall a (m :: * -> *) b. m (Can a b) -> CanT a m b
CanT (f (Can a b) -> CanT a f b)
-> (CanT a f a -> f (Can a b)) -> CanT a f a -> CanT a f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Can a a -> Can a b) -> f (Can a a) -> f (Can a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Can a a -> Can a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) (f (Can a a) -> f (Can a b))
-> (CanT a f a -> f (Can a a)) -> CanT a f a -> f (Can a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CanT a f a -> f (Can a a)
forall a (m :: * -> *) b. CanT a m b -> m (Can a b)
runCanT

instance (Semigroup a, Applicative f) => Applicative (CanT a f) where
  pure :: a -> CanT a f a
pure = f (Can a a) -> CanT a f a
forall a (m :: * -> *) b. m (Can a b) -> CanT a m b
CanT (f (Can a a) -> CanT a f a)
-> (a -> f (Can a a)) -> a -> CanT a f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Can a a -> f (Can a a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Can a a -> f (Can a a)) -> (a -> Can a a) -> a -> f (Can a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Can a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  CanT f :: f (Can a (a -> b))
f <*> :: CanT a f (a -> b) -> CanT a f a -> CanT a f b
<*> CanT a :: f (Can a a)
a = f (Can a b) -> CanT a f b
forall a (m :: * -> *) b. m (Can a b) -> CanT a m b
CanT (f (Can a b) -> CanT a f b) -> f (Can a b) -> CanT a f b
forall a b. (a -> b) -> a -> b
$ (Can a (a -> b) -> Can a a -> Can a b)
-> f (Can a (a -> b)) -> f (Can a a) -> f (Can a b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Can a (a -> b) -> Can a a -> Can a b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>) f (Can a (a -> b))
f f (Can a a)
a

instance (Semigroup a, Monad m) => Monad (CanT a m) where
  return :: a -> CanT a m a
return = a -> CanT a m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

  CanT m :: m (Can a a)
m >>= :: CanT a m a -> (a -> CanT a m b) -> CanT a m b
>>= k :: a -> CanT a m b
k = m (Can a b) -> CanT a m b
forall a (m :: * -> *) b. m (Can a b) -> CanT a m b
CanT (m (Can a b) -> CanT a m b) -> m (Can a b) -> CanT a m b
forall a b. (a -> b) -> a -> b
$ do
    Can a a
c <- m (Can a a)
m
    case Can a a
c of
      Eno a :: a
a -> CanT a m b -> m (Can a b)
forall a (m :: * -> *) b. CanT a m b -> m (Can a b)
runCanT (CanT a m b -> m (Can a b)) -> CanT a m b -> m (Can a b)
forall a b. (a -> b) -> a -> b
$ a -> CanT a m b
k a
a
      Two a :: a
a b :: a
b -> do
        Can a b
c' <- CanT a m b -> m (Can a b)
forall a (m :: * -> *) b. CanT a m b -> m (Can a b)
runCanT (CanT a m b -> m (Can a b)) -> CanT a m b -> m (Can a b)
forall a b. (a -> b) -> a -> b
$ a -> CanT a m b
k a
b
        Can a b -> m (Can a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Can a b -> m (Can a b)) -> Can a b -> m (Can a b)
forall a b. (a -> b) -> a -> b
$ case Can a b
c' of
          Eno b' :: b
b' -> a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
a b
b'
          Two a' :: a
a' b' :: b
b' -> a -> b -> Can a b
forall a b. a -> b -> Can a b
Two (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a') b
b'
          _ -> Can a b
c'
      One a :: a
a -> Can a b -> m (Can a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Can a b -> m (Can a b)) -> Can a b -> m (Can a b)
forall a b. (a -> b) -> a -> b
$ a -> Can a b
forall a b. a -> Can a b
One a
a
      Non -> Can a b -> m (Can a b)
forall (m :: * -> *) a. Monad m => a -> m a
return Can a b
forall a b. Can a b
Non

instance (Semigroup a, MonadWriter w m) => MonadWriter w (CanT a m) where
  tell :: w -> CanT a m ()
tell = m () -> CanT a m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> CanT a m ()) -> (w -> m ()) -> w -> CanT a m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell

  listen :: CanT a m a -> CanT a m (a, w)
listen (CanT m :: m (Can a a)
m) = m (Can a (a, w)) -> CanT a m (a, w)
forall a (m :: * -> *) b. m (Can a b) -> CanT a m b
CanT (m (Can a (a, w)) -> CanT a m (a, w))
-> m (Can a (a, w)) -> CanT a m (a, w)
forall a b. (a -> b) -> a -> b
$ (Can a a, w) -> Can a (a, w)
forall a a b. (Can a a, b) -> Can a (a, b)
go ((Can a a, w) -> Can a (a, w))
-> m (Can a a, w) -> m (Can a (a, w))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Can a a) -> m (Can a a, w)
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen m (Can a a)
m where
    go :: (Can a a, b) -> Can a (a, b)
go (c :: Can a a
c,w :: b
w) = case Can a a
c of
      Non -> Can a (a, b)
forall a b. Can a b
Non
      One a :: a
a -> a -> Can a (a, b)
forall a b. a -> Can a b
One a
a
      Eno b :: a
b -> (a, b) -> Can a (a, b)
forall a b. b -> Can a b
Eno (a
b,b
w)
      Two a :: a
a b :: a
b -> a -> (a, b) -> Can a (a, b)
forall a b. a -> b -> Can a b
Two a
a (a
b, b
w)

  pass :: CanT a m (a, w -> w) -> CanT a m a
pass (CanT m :: m (Can a (a, w -> w))
m) = m (Can a a) -> CanT a m a
forall a (m :: * -> *) b. m (Can a b) -> CanT a m b
CanT (m (Can a a) -> CanT a m a) -> m (Can a a) -> CanT a m a
forall a b. (a -> b) -> a -> b
$ m (Can a a, w -> w) -> m (Can a a)
forall w (m :: * -> *) a. MonadWriter w m => m (a, w -> w) -> m a
pass (Can a (a, w -> w) -> (Can a a, w -> w)
forall a b a. Can a (b, a -> a) -> (Can a b, a -> a)
go (Can a (a, w -> w) -> (Can a a, w -> w))
-> m (Can a (a, w -> w)) -> m (Can a a, w -> w)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Can a (a, w -> w))
m) where -- collect $200.
    go :: Can a (b, a -> a) -> (Can a b, a -> a)
go = \case
      Non -> (Can a b
forall a b. Can a b
Non, a -> a
forall a. a -> a
id)
      One a :: a
a -> (a -> Can a b
forall a b. a -> Can a b
One a
a, a -> a
forall a. a -> a
id)
      Eno (a :: b
a,f :: a -> a
f) -> (b -> Can a b
forall a b. b -> Can a b
Eno b
a, a -> a
f)
      Two w :: a
w (a :: b
a,f :: a -> a
f) -> (a -> b -> Can a b
forall a b. a -> b -> Can a b
Two a
w b
a, a -> a
f)


instance (Semigroup a, MonadReader r m) => MonadReader r (CanT a m) where
  ask :: CanT a m r
ask = m r -> CanT a m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: (r -> r) -> CanT a m a -> CanT a m a
local f :: r -> r
f (CanT m :: m (Can a a)
m) = m (Can a a) -> CanT a m a
forall a (m :: * -> *) b. m (Can a b) -> CanT a m b
CanT ((r -> r) -> m (Can a a) -> m (Can a a)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f m (Can a a)
m)

instance (MonadState s m, Semigroup t) => MonadState s (CanT t m) where
  get :: CanT t m s
get = m s -> CanT t m s
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m s
forall s (m :: * -> *). MonadState s m => m s
get
  put :: s -> CanT t m ()
put = m () -> CanT t m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> CanT t m ()) -> (s -> m ()) -> s -> CanT t m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put

instance (Semigroup t, MonadRWS r w s m) => MonadRWS r w s (CanT t m)

instance MonadTrans (CanT a) where
  lift :: m a -> CanT a m a
lift = m (Can a a) -> CanT a m a
forall a (m :: * -> *) b. m (Can a b) -> CanT a m b
CanT (m (Can a a) -> CanT a m a)
-> (m a -> m (Can a a)) -> m a -> CanT a m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Can a a) -> m a -> m (Can a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Can a a
forall a b. b -> Can a b
Eno

instance (MonadError e m, Semigroup e) => MonadError e (CanT e m) where
  throwError :: e -> CanT e m a
throwError = m a -> CanT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> CanT e m a) -> (e -> m a) -> e -> CanT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
  catchError :: CanT e m a -> (e -> CanT e m a) -> CanT e m a
catchError (CanT m :: m (Can e a)
m) f :: e -> CanT e m a
f = m (Can e a) -> CanT e m a
forall a (m :: * -> *) b. m (Can a b) -> CanT a m b
CanT (m (Can e a) -> CanT e m a) -> m (Can e a) -> CanT e m a
forall a b. (a -> b) -> a -> b
$ m (Can e a) -> (e -> m (Can e a)) -> m (Can e a)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError m (Can e a)
m (CanT e m a -> m (Can e a)
forall a (m :: * -> *) b. CanT a m b -> m (Can a b)
runCanT (CanT e m a -> m (Can e a))
-> (e -> CanT e m a) -> e -> m (Can e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> CanT e m a
f)