-- 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 (MK m) = m return


-- | Lift a @Maybe@ into @MaybeK@.
toMaybeK :: Maybe a -> MaybeK a
{-# INLINE toMaybeK #-}
toMaybeK Nothing  = mzero
toMaybeK (Just a) = return 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 nothing just m =
    case runMaybeK m of
    Nothing -> nothing
    Just a  -> just a


instance Functor MaybeK where
    fmap f (MK m) = MK (\k -> m (k . f))

instance Applicative MaybeK where
    pure   = return
    (<*>)  = ap
    (*>)   = (>>)
    x <* y = x >>= \a -> y >> return a

instance Monad MaybeK where
    return a   = MK (\k -> k a)
    MK m >>= f = MK (\k -> m (\a -> case f a of MK n -> n 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 = mzero
    (<|>) = mplus

instance MonadPlus MaybeK where
    mzero       = MK (\_ -> Nothing)
    m `mplus` n = maybeK n return m

instance MonadError () MaybeK where
    throwError _   = mzero
    catchError m f = maybeK (f ()) return 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 (MKT m) = m (pure . Just)


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


-- | Lift an @MaybeK@ into an @MaybeKT@.
liftMaybeK :: (Applicative m) => MaybeK a -> MaybeKT m a
{-# INLINE liftMaybeK #-}
liftMaybeK = toMaybeKT . 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 = fmap toMaybeK . runMaybeKT


instance Functor (MaybeKT m) where
    fmap f (MKT m) = MKT (\k -> m (k . f))

instance Applicative (MaybeKT m) where
    pure   = return
    (<*>)  = ap
    (*>)   = (>>)
    x <* y = x >>= \a -> y >> return a

instance Monad (MaybeKT m) where
    return a    = MKT (\k -> k a)
    MKT m >>= f = MKT (\k -> m (\a -> case f a of MKT n -> n 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 = mzero
    (<|>) = mplus

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

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

instance MonadTrans MaybeKT where
    lift m = MKT (\k -> m >>= k)

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