{- |
Asynchronous exceptions can occur during the construction of a lazy data structure.
They are represent by a lazy data structure itself.


TODO:

* Check whether laziness behaviour is reasonable.
-}
module Control.Monad.Exception.Asynchronous where

import qualified Control.Monad.Exception.Synchronous as Sync

import Control.Monad (mplus, liftM, )
import Control.Applicative (Applicative, liftA, )
{-
import Data.Traversable (Traversable, )
import Data.Foldable (Foldable, )
-}

import Prelude hiding (sequence)


-- * Plain monad

{- |
Contains a value and a reason why the computation of the value of type @a@ was terminated.
Imagine @a@ as a list type, and an according operation like the 'readFile' operation.
If the exception part is 'Nothing' then the value could be constructed regularly.
If the exception part is 'Just' then the value could not be constructed completely.
However you can read the result of type @a@ lazily,
even if an exception occurs while it is evaluated.
If you evaluate the exception part,
then the result value is certainly computed completely.

However, we cannot provide functions
that combine several 'Exceptional' values,
due to the very different ways of combining the results of type @a@.
It is recommended to process the result value in an application specific way,
and after consumption of the result, throw a synchronous exception using 'toSynchronous'.
-}
data Exceptional e a =
   Exceptional {exception :: Maybe e, result :: a}
     deriving Show


{- |
Create an exceptional value without exception.
-}
pure :: a -> Exceptional e a
pure = Exceptional Nothing

{- |
Create an exceptional value with exception.
-}
broken :: e -> a -> Exceptional e a
broken e = Exceptional (Just e)


fromSynchronous :: a -> Sync.Exceptional e a -> Exceptional e a
fromSynchronous deflt x =
   force $ case x of
      Sync.Success y   -> Exceptional Nothing y
      Sync.Exception e -> Exceptional (Just e) deflt


fromSynchronousNull :: Sync.Exceptional e () -> Exceptional e ()
fromSynchronousNull = fromSynchronous ()

toSynchronous :: Exceptional e a -> Sync.Exceptional e a
toSynchronous (Exceptional me a) =
   maybe (Sync.Success a) Sync.Exception me


throw :: e -> Exceptional e ()
throw e = Exceptional (Just e) ()



{- |
Repeat an action with synchronous exceptions until an exception occurs.
Combine all atomic results using the @bind@ function.
It may be @cons = (:)@ and @empty = []@ for @b@ being a list type.
The @defer@ function may be @id@
or @unsafeInterleaveIO@ for lazy read operations.
The exception is returned as asynchronous exception.
-}
manySynchronousT :: (Monad m) =>
   (m (Exceptional e b) -> m (Exceptional e b))
                           {- ^ @defer@ function -} ->
   (a -> b -> b)           {- ^ @cons@ function -} ->
   b                       {- ^ @empty@ -} ->
   Sync.ExceptionalT e m a {- ^ atomic action to repeat -} ->
   m (Exceptional e b)
manySynchronousT defer cons empty action =
   let recurse =
          liftM force $ defer $
          do r <- Sync.tryT action
             case r of
                Sync.Exception e -> return (Exceptional (Just e) empty)
                Sync.Success x   -> liftM (fmap (cons x)) recurse
   in  recurse

{- |
Scan @x@ using the @decons@ function
and run an action with synchronous exceptions for each element fetched from @x@.
Each invocation of an element action may stop this function
due to an exception.
If all element action can be performed successfully
and if there is an asynchronous exception
then at the end this exception is raised as synchronous exception.
@decons@ function might be @viewL@.
-}
processToSynchronousT_ :: (Monad m) =>
   (b -> Maybe (a,b))  {- ^ decons function -} ->
   (a -> Sync.ExceptionalT e m ())
                       {- ^ action that is run for each element fetched from @x@ -} ->
   Exceptional e b     {- ^ value @x@ of type @b@ with asynchronous exception -} ->
   Sync.ExceptionalT e m ()
processToSynchronousT_ decons action (Exceptional me x) =
   let recurse b0 =
          maybe
             (maybe (return ()) Sync.throwT me)
             (\(a,b1) -> action a >> recurse b1)
             (decons b0)
   in  recurse x


-- ** handling of special result types

{- |
This is an example for application specific handling of result values.
Assume you obtain two lazy lists say from 'readFile'
and you want to zip their contents.
If one of the stream readers emits an exception,
we quit with that exception.
If both streams have throw an exception at the same file position,
the exception of the first stream is propagated.
-}
zipWith ::
   (a -> b -> c) ->
   Exceptional e [a] -> Exceptional e [b] -> Exceptional e [c]
zipWith f (Exceptional ea a0) (Exceptional eb b0) =
   let recurse (a:as) (b:bs) =
          fmap (f a b :) (recurseF as bs)
       recurse as _ =
          Exceptional (case as of [] -> mplus ea eb; _ -> eb) []
       recurseF as bs = force $ recurse as bs
   in  recurseF a0 b0


{- | construct Exceptional constructor lazily -}
force :: Exceptional e a -> Exceptional e a
force (~(Exceptional e a)) = Exceptional e a


{-
catch :: Exceptional e0 a -> (e0 -> Exceptional e1 a) -> Exceptional e1 a
catch x handler =
   case x of
      Success a   -> Success a
      Exception e -> handler e
-}

instance Functor (Exceptional e) where
   fmap f x =
      case x of
         ~(Exceptional e a) -> Exceptional e (f a)

{-
Foldable instance would allow to strip off the exception too easily.

instance Foldable (Exceptional e) where


I like the methods of traversable, but Traversable instance requires Foldable instance

instance Traversable (Exceptional e) where
-}

{-# INLINE traverse #-}
traverse :: Applicative f => (a -> f b) -> Exceptional e a -> f (Exceptional e b)
traverse f = sequenceA . fmap f

{-# INLINE sequenceA #-}
sequenceA :: Applicative f => Exceptional e (f a) -> f (Exceptional e a)
sequenceA ~(Exceptional e a) =
   liftA (Exceptional e) a

{-# INLINE mapM #-}
mapM :: Monad m => (a -> m b) -> Exceptional e a -> m (Exceptional e b)
mapM f = sequence . fmap f

{-# INLINE sequence #-}
sequence :: Monad m => Exceptional e (m a) -> m (Exceptional e a)
sequence ~(Exceptional e a) =
   liftM (Exceptional e) a



{-
instance Applicative (Exceptional e) where
   pure = Exceptional [] -- [Nothing]?
   f <*> x =
      case f of
         Exceptional e0 g ->
            case x of
               Exceptional e1 y -> Exceptional (mplus e0 e1) (g y)

instance Monad (Exceptional e) where
   return = Exceptional [] -- [Nothing]?
   fail _msg =
      Exceptional
         [Just (error "Asynchronous.fail exception")]
         (error "Asynchronous.fail result")
   x >>= f =
      case x of
         Exceptional e0 y ->
            case f y of
               Exceptional e1 z -> Exceptional (e0 ++ e1) z


-- * Monad transformer

newtype ExceptionalT e m a =
   ExceptionalT {runExceptionalT :: m (Exceptional e a)}


fromSynchronousT :: Functor m =>
   a -> Sync.ExceptionalT e m a -> ExceptionalT e m a
fromSynchronousT deflt (Sync.ExceptionalT mx) =
   ExceptionalT $ fmap (fromSynchronous deflt) mx



throwT :: (Monad m) =>
   e -> ExceptionalT e m ()
throwT = ExceptionalT . return . throw



instance Functor m => Functor (ExceptionalT e m) where
   fmap f (ExceptionalT x) =
      ExceptionalT (fmap (fmap f) x)

instance Applicative m => Applicative (ExceptionalT e m) where
   pure = ExceptionalT . pure . pure
   ExceptionalT f <*> ExceptionalT x =
      ExceptionalT (fmap (<*>) f <*> x)

instance Monad m => Monad (ExceptionalT e m) where
   return = ExceptionalT . return . return
   x0 >>= f =
      ExceptionalT $
      do Exceptional ex x <- runExceptionalT x0
         Exceptional ey y <- runExceptionalT (f x)
         return $ Exceptional (ex ++ ey) y
-}