-- The MPTCs is only for mtl:Control.Monad.Error.MonadError
{-# LANGUAGE CPP, Rank2Types, MultiParamTypeClasses #-}
{-# OPTIONS_GHC -Wall -fwarn-tabs #-}

-- HACK: in GHC 7.10, Haddock complains about unused imports; but,
-- if we use CPP to avoid including them under Haddock, then it
-- will fail!
#ifdef __HADDOCK__
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
#endif

----------------------------------------------------------------
--                                                  ~ 2015.03.29
-- |
-- Module      :  Control.Monad.MaybeK
-- License     :  BSD
-- Maintainer  :  wren@community.haskell.org
-- Stability   :  provisional
-- Portability :  semi-portable (CPP, Rank2Types, MPTCs)
--
-- A continuation-passing variant of 'Maybe' for short-circuiting
-- at failure. This is based largely on code from the Haskell Wiki
-- (<http://www.haskell.org/haskellwiki/Performance/Monads>) which
-- was released under a simple permissive license
-- (<http://www.haskell.org/haskellwiki/HaskellWiki:Copyrights>).
-- However, various changes and extensions have been made, which
-- are subject to the BSD license of this package.
----------------------------------------------------------------
module Control.Monad.MaybeK
    (
    -- * The partiality monad
      MaybeK
    , runMaybeK
    , toMaybeK
    , maybeK
    -- * The partiality monad transformer
    , MaybeKT
    , runMaybeKT
    , toMaybeKT
    , liftMaybeK
    , lowerMaybeK
    ) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative  (Applicative(..))
#endif
import Control.Applicative  (Alternative(..))
import Control.Monad        (MonadPlus(..), ap)
import Control.Monad.Trans  (MonadTrans(..))
#if (MIN_VERSION_mtl(2,2,1))
-- aka: transformers(0,4,1)
import Control.Monad.Except (MonadError(..))
#else
import Control.Monad.Error  (MonadError(..))
#endif
----------------------------------------------------------------
----------------------------------------------------------------

-- | A continuation-passing encoding of 'Maybe'; also known as
-- @Codensity Maybe@, if you're familiar with that terminology.
-- N.B., this is not the 2-continuation implementation based on the
-- Church encoding of @Maybe@. The latter tends to have worse
-- performance than non-continuation based implementations.
--
-- This is generally more efficient than using @Maybe@ for two
-- reasons. First is that it right associates all binds, ensuring
-- that bad associativity doesn't artificially introduce midpoints
-- in short-circuiting to the nearest handler. Second is that it
-- removes the need for intermediate case expressions.
--
-- N.B., the 'Alternative' and 'MonadPlus' instances are left-biased
-- in @a@. Thus, they are not commutative.
newtype MaybeK a = MK (forall r. (a -> Maybe r) -> Maybe r)


-- | Execute the @MaybeK@ and return the concrete @Maybe@ encoding.
runMaybeK :: MaybeK a -> Maybe a
{-# INLINE runMaybeK #-}
runMaybeK :: MaybeK a -> Maybe a
runMaybeK (MK forall r. (a -> Maybe r) -> Maybe r
m) = (a -> Maybe a) -> Maybe a
forall r. (a -> Maybe r) -> Maybe r
m a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return


-- | Lift a @Maybe@ into @MaybeK@.
toMaybeK :: Maybe a -> MaybeK a
{-# INLINE toMaybeK #-}
toMaybeK :: Maybe a -> MaybeK a
toMaybeK Maybe a
Nothing  = MaybeK a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
toMaybeK (Just a
a) = a -> MaybeK a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


-- | A version of 'maybe' for convenience. This is almost identical
-- to 'mplus' but allows applying a continuation to @Just@ values
-- as well as handling @Nothing@ errors. If you only want to handle
-- the errors, use 'mplus' instead.
maybeK :: b -> (a -> b) -> MaybeK a -> b
{-# INLINE maybeK #-}
maybeK :: b -> (a -> b) -> MaybeK a -> b
maybeK b
nothing a -> b
just MaybeK a
m =
    case MaybeK a -> Maybe a
forall a. MaybeK a -> Maybe a
runMaybeK MaybeK a
m of
    Maybe a
Nothing -> b
nothing
    Just a
a  -> a -> b
just a
a


instance Functor MaybeK where
    fmap :: (a -> b) -> MaybeK a -> MaybeK b
fmap a -> b
f (MK forall r. (a -> Maybe r) -> Maybe r
m) = (forall r. (b -> Maybe r) -> Maybe r) -> MaybeK b
forall a. (forall r. (a -> Maybe r) -> Maybe r) -> MaybeK a
MK (\b -> Maybe r
k -> (a -> Maybe r) -> Maybe r
forall r. (a -> Maybe r) -> Maybe r
m (b -> Maybe r
k (b -> Maybe r) -> (a -> b) -> a -> Maybe r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))

instance Applicative MaybeK where
    pure :: a -> MaybeK a
pure   = a -> MaybeK a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: MaybeK (a -> b) -> MaybeK a -> MaybeK b
(<*>)  = MaybeK (a -> b) -> MaybeK a -> MaybeK b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
    *> :: MaybeK a -> MaybeK b -> MaybeK b
(*>)   = MaybeK a -> MaybeK b -> MaybeK b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>)
    MaybeK a
x <* :: MaybeK a -> MaybeK b -> MaybeK a
<* MaybeK b
y = MaybeK a
x MaybeK a -> (a -> MaybeK a) -> MaybeK a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> MaybeK b
y MaybeK b -> MaybeK a -> MaybeK a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> MaybeK a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

instance Monad MaybeK where
    return :: a -> MaybeK a
return a
a   = (forall r. (a -> Maybe r) -> Maybe r) -> MaybeK a
forall a. (forall r. (a -> Maybe r) -> Maybe r) -> MaybeK a
MK (\a -> Maybe r
k -> a -> Maybe r
k a
a)
    MK forall r. (a -> Maybe r) -> Maybe r
m >>= :: MaybeK a -> (a -> MaybeK b) -> MaybeK b
>>= a -> MaybeK b
f = (forall r. (b -> Maybe r) -> Maybe r) -> MaybeK b
forall a. (forall r. (a -> Maybe r) -> Maybe r) -> MaybeK a
MK (\b -> Maybe r
k -> (a -> Maybe r) -> Maybe r
forall r. (a -> Maybe r) -> Maybe r
m (\a
a -> case a -> MaybeK b
f a
a of MK forall r. (b -> Maybe r) -> Maybe r
n -> (b -> Maybe r) -> Maybe r
forall r. (b -> Maybe r) -> Maybe r
n b -> Maybe r
k))
    -- Using case instead of let seems to improve performance
    -- considerably by removing excessive laziness.

-- This is non-commutative, but it's the same as Alternative Maybe.
instance Alternative MaybeK where
    empty :: MaybeK a
empty = MaybeK a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    <|> :: MaybeK a -> MaybeK a -> MaybeK a
(<|>) = MaybeK a -> MaybeK a -> MaybeK a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance MonadPlus MaybeK where
    mzero :: MaybeK a
mzero       = (forall r. (a -> Maybe r) -> Maybe r) -> MaybeK a
forall a. (forall r. (a -> Maybe r) -> Maybe r) -> MaybeK a
MK (\a -> Maybe r
_ -> Maybe r
forall a. Maybe a
Nothing)
    MaybeK a
m mplus :: MaybeK a -> MaybeK a -> MaybeK a
`mplus` MaybeK a
n = MaybeK a -> (a -> MaybeK a) -> MaybeK a -> MaybeK a
forall b a. b -> (a -> b) -> MaybeK a -> b
maybeK MaybeK a
n a -> MaybeK a
forall (m :: * -> *) a. Monad m => a -> m a
return MaybeK a
m

instance MonadError () MaybeK where
    throwError :: () -> MaybeK a
throwError ()
_   = MaybeK a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    catchError :: MaybeK a -> (() -> MaybeK a) -> MaybeK a
catchError MaybeK a
m () -> MaybeK a
f = MaybeK a -> (a -> MaybeK a) -> MaybeK a -> MaybeK a
forall b a. b -> (a -> b) -> MaybeK a -> b
maybeK (() -> MaybeK a
f ()) a -> MaybeK a
forall (m :: * -> *) a. Monad m => a -> m a
return MaybeK a
m

----------------------------------------------------------------

-- | A monad transformer version of 'MaybeK'.
newtype MaybeKT m a = MKT (forall r . (a -> m (Maybe r)) -> m (Maybe r))


-- | Execute a @MaybeKT@ and return the concrete @Maybe@ encoding.
runMaybeKT :: (Applicative m) => MaybeKT m a -> m (Maybe a)
{-# INLINE runMaybeKT #-}
runMaybeKT :: MaybeKT m a -> m (Maybe a)
runMaybeKT (MKT forall r. (a -> m (Maybe r)) -> m (Maybe r)
m) = (a -> m (Maybe a)) -> m (Maybe a)
forall r. (a -> m (Maybe r)) -> m (Maybe r)
m (Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m (Maybe a)) -> (a -> Maybe a) -> a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just)


-- | Lift a @Maybe@ into an @MaybeKT@.
toMaybeKT :: (Applicative m) => Maybe a -> MaybeKT m a
{-# INLINE toMaybeKT #-}
toMaybeKT :: Maybe a -> MaybeKT m a
toMaybeKT Maybe a
Nothing  = (forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a
forall (m :: * -> *) a.
(forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a
MKT (\a -> m (Maybe r)
_ -> Maybe r -> m (Maybe r)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe r
forall a. Maybe a
Nothing)
toMaybeKT (Just a
a) = a -> MaybeKT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a


-- | Lift an @MaybeK@ into an @MaybeKT@.
liftMaybeK :: (Applicative m) => MaybeK a -> MaybeKT m a
{-# INLINE liftMaybeK #-}
liftMaybeK :: MaybeK a -> MaybeKT m a
liftMaybeK = Maybe a -> MaybeKT m a
forall (m :: * -> *) a. Applicative m => Maybe a -> MaybeKT m a
toMaybeKT (Maybe a -> MaybeKT m a)
-> (MaybeK a -> Maybe a) -> MaybeK a -> MaybeKT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeK a -> Maybe a
forall a. MaybeK a -> Maybe a
runMaybeK
--
-- With the above implementation, when @liftMaybeK x@ is forced it
-- will force not only @x = MK m@, but will also force @m@. If we
-- want to force only @x@ and to defer @m@, then we should use the
-- following implementation instead:
--
-- > liftMaybeK (MK m) = MKT (\k -> maybe (return Nothing) k (m Just))
--
-- Or if we want to defer both @m@ and @x@, then we could use:
--
-- > liftMaybeK x = MKT (\k -> maybe (return Nothing) k (runMaybeK x))
--
-- However, all versions need to reify @m@ at some point, and
-- therefore will lose short-circuiting. This is necessary since
-- given some @k :: a -> m (Maybe r)@ we have no way of constructing
-- the needed @k' :: a -> Maybe r@ from it without prematurely
-- executing the side-effects.


-- | Lower an @MaybeKT@ into an @MaybeK@.
lowerMaybeK :: (Applicative m) => MaybeKT m a -> m (MaybeK a)
{-# INLINE lowerMaybeK #-}
lowerMaybeK :: MaybeKT m a -> m (MaybeK a)
lowerMaybeK = (Maybe a -> MaybeK a) -> m (Maybe a) -> m (MaybeK a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe a -> MaybeK a
forall a. Maybe a -> MaybeK a
toMaybeK (m (Maybe a) -> m (MaybeK a))
-> (MaybeKT m a -> m (Maybe a)) -> MaybeKT m a -> m (MaybeK a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeKT m a -> m (Maybe a)
forall (m :: * -> *) a. Applicative m => MaybeKT m a -> m (Maybe a)
runMaybeKT


instance Functor (MaybeKT m) where
    fmap :: (a -> b) -> MaybeKT m a -> MaybeKT m b
fmap a -> b
f (MKT forall r. (a -> m (Maybe r)) -> m (Maybe r)
m) = (forall r. (b -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m b
forall (m :: * -> *) a.
(forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a
MKT (\b -> m (Maybe r)
k -> (a -> m (Maybe r)) -> m (Maybe r)
forall r. (a -> m (Maybe r)) -> m (Maybe r)
m (b -> m (Maybe r)
k (b -> m (Maybe r)) -> (a -> b) -> a -> m (Maybe r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))

instance Applicative (MaybeKT m) where
    pure :: a -> MaybeKT m a
pure   = a -> MaybeKT m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: MaybeKT m (a -> b) -> MaybeKT m a -> MaybeKT m b
(<*>)  = MaybeKT m (a -> b) -> MaybeKT m a -> MaybeKT m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
    *> :: MaybeKT m a -> MaybeKT m b -> MaybeKT m b
(*>)   = MaybeKT m a -> MaybeKT m b -> MaybeKT m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>)
    MaybeKT m a
x <* :: MaybeKT m a -> MaybeKT m b -> MaybeKT m a
<* MaybeKT m b
y = MaybeKT m a
x MaybeKT m a -> (a -> MaybeKT m a) -> MaybeKT m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> MaybeKT m b
y MaybeKT m b -> MaybeKT m a -> MaybeKT m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> MaybeKT m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

instance Monad (MaybeKT m) where
    return :: a -> MaybeKT m a
return a
a    = (forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a
forall (m :: * -> *) a.
(forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a
MKT (\a -> m (Maybe r)
k -> a -> m (Maybe r)
k a
a)
    MKT forall r. (a -> m (Maybe r)) -> m (Maybe r)
m >>= :: MaybeKT m a -> (a -> MaybeKT m b) -> MaybeKT m b
>>= a -> MaybeKT m b
f = (forall r. (b -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m b
forall (m :: * -> *) a.
(forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a
MKT (\b -> m (Maybe r)
k -> (a -> m (Maybe r)) -> m (Maybe r)
forall r. (a -> m (Maybe r)) -> m (Maybe r)
m (\a
a -> case a -> MaybeKT m b
f a
a of MKT forall r. (b -> m (Maybe r)) -> m (Maybe r)
n -> (b -> m (Maybe r)) -> m (Maybe r)
forall r. (b -> m (Maybe r)) -> m (Maybe r)
n b -> m (Maybe r)
k))

-- In order to define a @(<|>)@ which only requires @Applicative
-- m@ we'd need a law @m (Either e a) -> Either (m e) (m a)@; or
-- equivalently, we'd need to use a 2-CPS style.
instance (Applicative m, Monad m) => Alternative (MaybeKT m) where
    empty :: MaybeKT m a
empty = MaybeKT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    <|> :: MaybeKT m a -> MaybeKT m a -> MaybeKT m a
(<|>) = MaybeKT m a -> MaybeKT m a -> MaybeKT m a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance (Applicative m, Monad m) => MonadPlus (MaybeKT m) where
    mzero :: MaybeKT m a
mzero = (forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a
forall (m :: * -> *) a.
(forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a
MKT (\a -> m (Maybe r)
_ -> Maybe r -> m (Maybe r)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe r
forall a. Maybe a
Nothing)
    
    MaybeKT m a
m mplus :: MaybeKT m a -> MaybeKT m a -> MaybeKT m a
`mplus` MaybeKT m a
n = (forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a
forall (m :: * -> *) a.
(forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a
MKT ((forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a)
-> (forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a
forall a b. (a -> b) -> a -> b
$ \a -> m (Maybe r)
k -> do
        Maybe a
mb <- MaybeKT m a -> m (Maybe a)
forall (m :: * -> *) a. Applicative m => MaybeKT m a -> m (Maybe a)
runMaybeKT MaybeKT m a
m
        case Maybe a
mb of
            Maybe a
Nothing -> case MaybeKT m a
n of MKT forall r. (a -> m (Maybe r)) -> m (Maybe r)
n' -> (a -> m (Maybe r)) -> m (Maybe r)
forall r. (a -> m (Maybe r)) -> m (Maybe r)
n' a -> m (Maybe r)
k
            Just a
a  -> a -> m (Maybe r)
k a
a

instance (Applicative m, Monad m) => MonadError () (MaybeKT m) where
    throwError :: () -> MaybeKT m a
throwError ()
_   = MaybeKT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    catchError :: MaybeKT m a -> (() -> MaybeKT m a) -> MaybeKT m a
catchError MaybeKT m a
m () -> MaybeKT m a
f = (forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a
forall (m :: * -> *) a.
(forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a
MKT ((forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a)
-> (forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a
forall a b. (a -> b) -> a -> b
$ \a -> m (Maybe r)
k -> do
        Maybe a
mb <- MaybeKT m a -> m (Maybe a)
forall (m :: * -> *) a. Applicative m => MaybeKT m a -> m (Maybe a)
runMaybeKT MaybeKT m a
m
        case Maybe a
mb of
            Maybe a
Nothing -> case () -> MaybeKT m a
f () of MKT forall r. (a -> m (Maybe r)) -> m (Maybe r)
n -> (a -> m (Maybe r)) -> m (Maybe r)
forall r. (a -> m (Maybe r)) -> m (Maybe r)
n a -> m (Maybe r)
k
            Just a
a  -> a -> m (Maybe r)
k a
a

instance MonadTrans MaybeKT where
    lift :: m a -> MaybeKT m a
lift m a
m = (forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a
forall (m :: * -> *) a.
(forall r. (a -> m (Maybe r)) -> m (Maybe r)) -> MaybeKT m a
MKT (\a -> m (Maybe r)
k -> m a
m m a -> (a -> m (Maybe r)) -> m (Maybe r)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m (Maybe r)
k)

----------------------------------------------------------------
----------------------------------------------------------- fin.