{-# OPTIONS -fglasgow-exts -fno-warn-orphans  #-} 
{-# LANGUAGE ScopedTypeVariables, UndecidableInstances #-}

{- |
Module      :  Control.Monad.ErrorX
Copyright   :  (c) Mark Snyder 2008.
License     :  BSD-style
Maintainer  :  Mark Snyder, marks@ittc.ku.edu
Stability   :  experimental
Portability :  non-portable (multi-parameter type classes)
-}

module Control.Monad.ErrorX (
    module Control.Monad.ErrorX.Class,
    ErrorTX(..),
    runErrorTX,
    mapErrorTX,
    module Control.Monad,
    module Control.Monad.Fix,
    module Control.Monad.Trans,
    module Control.Monad.Index
  ) where

import Control.Monad
import Control.Monad.Cont.Class
import Control.Monad.Error
import Control.Monad.Fix
import Control.Monad.RWS.Class
import Control.Monad.Reader.Class
import Control.Monad.State.Class
import Control.Monad.Trans
import Control.Monad.Writer.Class

import Control.Monad.Instances ()
import System.IO

import Control.Monad.Index
import Control.Monad.ErrorX.Class
import Control.Monad.ReaderX.Class
import Control.Monad.StateX.Class
import Control.Monad.WriterX.Class

{-
instance MonadPlus IO where
    mzero       = ioError (userError "mzero")
    m `mplus` n = m `catch` \_ -> n
-}

instance (Index ix) => MonadErrorX ix IOError IO where
    throwErrorx (_::ix) = ioError
    catchErrorx (_::ix) = catch

-- ---------------------------------------------------------------------------
-- Our parameterizable error monad

{-
instance (Error e) => Monad (Either e) where
    return        = Right
    Left  l >>= _ = Left l
    Right r >>= k = k r
    fail msg      = Left (strMsg msg)

instance (Error e) => MonadPlus (Either e) where
    mzero            = Left noMsg
    Left _ `mplus` n = n
    m      `mplus` _ = m

instance (Error e) => MonadFix (Either e) where
    mfix f = let
        a = f $ case a of
            Right r -> r
            _       -> error "empty mfix argument"
        in a
-}
instance (Error e, Index ix) => MonadErrorX ix e (Either e) where
    throwErrorx (_::ix)             = Left
    catchErrorx (_::ix) (Left  l) h = h l
    catchErrorx (_::ix) (Right r) _ = Right r

{- |
The error monad transformer. It can be used to add error handling to other
monads.

The @ErrorT@ Monad structure is parameterized over two things:

 * e - The error type.

 * m - The inner monad.

Here are some examples of use:

> -- wraps IO action that can throw an error e
> type ErrorWithIO e a = ErrorT e IO a
> ==> ErrorT (IO (Either e a))
>
> -- IO monad wrapped in StateT inside of ErrorT
> type ErrorAndStateWithIO e s a = ErrorT e (StateT s IO) a
> ==> ErrorT (StateT s IO (Either e a))
> ==> ErrorT (StateT (s -> IO (Either e a,s)))

-}

--data (Index ix) => data ErrorTX ix e m a = ErrorTX ix e m a
--runErrorTX (_::ix) (ErrorTX (_::ix) m) = 

-- newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) }

data (Index ix) => ErrorTX ix e m a = ErrorTX ix (m (Either e a))
runErrorTX :: (Index ix) => ix -> ErrorTX ix e m a -> m (Either e a)
runErrorTX (_::ix) (ErrorTX (_::ix) f) = f

--instead of... newtype (Index ix) => ErrorTX ix e m a = ErrorTX ix { runErrorT :: m (Either e a) }

mapErrorTX :: (Index ix) => ix 
          -> (m (Either e a) -> n (Either e' b))
          -> ErrorTX ix e m a
          -> ErrorTX ix e' n b
mapErrorTX ixv f m = ErrorTX ixv $ f (runErrorTX ixv m)

instance (Monad m, Index ix) => Functor (ErrorTX ix e m) where
    fmap f m = ErrorTX (getVal::ix) $ do
        a <- runErrorTX (getVal::ix) m
        case a of
            Left  l -> return (Left  l)
            Right r -> return (Right (f r))

instance (Monad m, Error e, Index ix) => Monad (ErrorTX ix e m) where
    return a = ErrorTX (getVal::ix) $ return (Right a)
    m >>= k  = ErrorTX (getVal::ix) $ do
        a <- runErrorTX (getVal::ix) m
        case a of
            Left  l -> return (Left l)
            Right r -> runErrorTX (getVal::ix) (k r)
    fail msg = ErrorTX (getVal::ix) $ return (Left (strMsg msg))

instance (Monad m, Error e, Index ix) => MonadPlus (ErrorTX ix e m) where
    mzero       = ErrorTX (getVal::ix) $ return (Left noMsg)
    m `mplus` n = ErrorTX (getVal::ix) $ do
        a <- runErrorTX (getVal::ix) m
        case a of
            Left  _ -> runErrorTX (getVal::ix) n
            Right r -> return (Right r)

instance (MonadFix m, Error e, Index ix) => MonadFix (ErrorTX ix e m) where
    mfix f = ErrorTX (getVal::ix) $ mfix $ \a -> runErrorTX (getVal::ix) $ f $ case a of
        Right r -> r
        _       -> error "empty mfix argument"

instance (Monad m, Error e, Index ix) => MonadErrorX ix e (ErrorTX ix e m) where
    throwErrorx (ixv::ix) l    = ErrorTX ixv $ return (Left l)
    catchErrorx (ixv::ix) m  h = ErrorTX ixv $ do
        a <- runErrorTX ixv m
        case a of
            Left  l -> runErrorTX ixv (h l)
            Right r -> return (Right r)

-- ---------------------------------------------------------------------------
-- Instances for other mtl transformers

instance (Error e, Index ixe) => MonadTrans (ErrorTX ixe e) where
    lift m = ErrorTX (getVal::ixe) $ do
        a <- m
        return (Right a)

instance (Error e, MonadIO m, Index ixe) => MonadIO (ErrorTX ixe e m) where
    liftIO = lift . liftIO

instance (Error e, MonadCont m, Index ixe) => MonadCont (ErrorTX ixe e m) where
    callCC f = ErrorTX (getVal::ixe) $
        callCC $ \c ->
        runErrorTX (getVal::ixe) (f (\a -> ErrorTX (getVal::ixe) $ c (Right a)))

instance (Error e, MonadRWS r w s m, Index ixe) => MonadRWS r w s (ErrorTX ixe e m)

{-
does there need to be some more framework in place to handle multiple
errors possibly piping through?  Maybe I just don't understand this
enough yet.

instance (Monad m, Error e1, Error e2, Index ix1, Index ix2) => MonadErrorX ix1 e1 (ErrorTX ix2 e2 m) where
    throwErrorx (_::ix1)  (v::e1) = ErrorTX (getVal::ix2) $ return $ Right (Left v)
    catchErrorx (ixv::ix1) (m::ErrorTX ix2 e2 m a) (h::e1 -> ErrorTX ix2 e2 m a)    = ErrorTX (getVal::ix2) $ do
        a <- runErrorTX ixv m
        return undefined
--        case a of
--            Left  l -> runErrorTX (getVal::ix1) (h l)
--            Right r -> return (Right r)
-}

instance (Error e, MonadReader r m, Index ixe) => MonadReader r (ErrorTX ixe e m) where
    ask       = lift ask
    local f m = ErrorTX (getVal::ixe) $ local f (runErrorTX (getVal::ixe) m)

instance (Error e, MonadState s m, Index ixe) => MonadState s (ErrorTX ixe e m) where
    get = lift get
    put = lift . put

instance (Error e, MonadWriter w m, Index ixe) => MonadWriter w (ErrorTX ixe e m) where
    tell     = lift . tell
    listen m = ErrorTX (getVal::ixe) $ do
        (a, w) <- listen (runErrorTX (getVal::ixe) m)
        case a of
            Left  l -> return $ Left  l
            Right r -> return $ Right (r, w)
    pass   m = ErrorTX (getVal::ixe) $ pass $ do
        a <- runErrorTX (getVal::ixe) m
        case a of
            Left  l      -> return (Left  l, id)
            Right (r, f) -> return (Right r, f)






instance (Error e, MonadReaderX ixr r m, Index ixr, Index ixe) => MonadReaderX ixr r (ErrorTX ixe e m) where
    askx (ixv::ixr)       = lift $ askx ixv
    localx (ixv::ixr) f m = ErrorTX (getVal::ixe) $ localx ixv f (runErrorTX (getVal::ixe) m)

instance (Error e, Index ixs, MonadStateX ixs s m, Index ixe) => MonadStateX ixs s (ErrorTX ixe e m) where
    getx (ixv::ixs) = lift $ getx ixv
    putx (ixv::ixs) = lift . putx ixv

instance (Error e, Index ixw, MonadWriterX ixw w m, Index ixe) => MonadWriterX ixw w (ErrorTX ixe e m) where
    tellx (ixv::ixw)     = lift . tellx ixv
    listenx (ixv::ixw) m = ErrorTX (getVal::ixe) $ do
        (a, w) <- listenx ixv (runErrorTX (getVal::ixe) m)
        case a of
            Left  l -> return $ Left  l
            Right r -> return $ Right (r, w)
    passx (ixv::ixw)   m = ErrorTX (getVal::ixe) $ passx ixv $ do
        a <- runErrorTX (getVal::ixe) m
        case a of
            Left  l      -> return (Left  l, id)
            Right (r, f) -> return (Right r, f)