{-# LANGUAGE NoMonomorphismRestriction, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}
module Tools.Errors 
  ( Errors, runErrors, ErrorsT, runErrorsT, module Tools.Errors.Class ) where

import Control.Applicative
import Control.Monad.Error
import Control.Monad.Writer
import Control.Monad.Reader(ReaderT, mapReaderT)
import Control.Monad.Reader.Class

import Tools.Instances
import Tools.Errors.Class

data Errors e a
  = Result a
  | Errors e a
  | Fatal e 

instance Functor (Errors e) where
  fmap f (Result x) = Result (f x)
  fmap f (Errors e x) = Errors e (f x)
  fmap f (Fatal e) = Fatal e

instance (Monoid e, Error e) => Applicative (Errors e) where
  pure = return
  (<*>) = ap
  
instance (Monoid e, Error e) => Monad (Errors e) where
  return x = Result x

  Result x >>= f = f x
  Errors e x >>= f = case f x of
    Result y -> Errors e y
    Errors e' y -> Errors (e `mappend` e') y
    Fatal e' -> Fatal (e `mappend` e')
  Fatal e >>= f = Fatal e
  
  fail msg = Fatal (strMsg msg)

instance (Monoid e, Error e) => MonadError e (Errors e) where
  throwError = Fatal
  Result x `catchError` h = Result x
  Errors e a `catchError` h = h e 
  Fatal e `catchError` h = h e  

instance (Monoid e, Error e) => MonadErrors e (Errors e) where
  annotate f (Result x) = Result x
  annotate f (Errors e x) = Errors (f e) x
  annotate f (Fatal e) = Fatal (f e)
  
  recover x' (Result x) = Result x
  recover x' (Errors e x) = Errors e x
  recover x' (Fatal e) = Errors e x'

runErrors (Result x) = Right x
runErrors (Errors e x) = Left e
runErrors (Fatal e) = Left e

newtype ErrorsT e m a = ErrorsT (m (Errors e a))

unErrorsT (ErrorsT x) = x

instance (Error e, Monoid e, Monad m) => Functor (ErrorsT e m) where
  fmap = liftM

instance (Monoid e, Error e, Functor m, Monad m) => Applicative (ErrorsT e m) where
  pure = return
  (<*>) = ap

instance (Monoid e, Error e, Monad m) => Monad (ErrorsT e m) where
  return = ErrorsT . return . return
  
  ErrorsT p >>= f = ErrorsT $ p >>= left where
    left (Result x) = unErrorsT (f x)
    left (Errors e x) = unErrorsT (f x) >>= right where 
      right (Result y)    = return (Errors e y)
      right (Errors e' y) = return (Errors (mappend e e') y)
      right (Fatal e')    = return (Fatal (mappend e e'))
    left (Fatal e) = return (Fatal e)
    
  fail = ErrorsT . return . Fatal . strMsg 

instance (Monoid e, Error e, Monad m) => MonadError e (ErrorsT e m) where
  throwError = ErrorsT . return . Fatal
  
  ErrorsT p `catchError` h = ErrorsT $ p >>= foo where
    foo (Result x) = return (Result x)
    foo (Errors e a) = unErrorsT (h e)
    foo (Fatal e) = unErrorsT (h e)

instance (Monoid e, Error e, Monad m) => MonadErrors e (ErrorsT e m) where
  annotate f (ErrorsT p) = ErrorsT $ annotate f `liftM` p
  recover x (ErrorsT p) = ErrorsT $ recover x `liftM` p

runErrorsT :: (Error e, Monad m) =>  ErrorsT e m a -> m (Either e a) 
runErrorsT (ErrorsT p) = liftM runErrors p

instance Monoid e => MonadTrans (ErrorsT e) where
  lift = ErrorsT . liftM Result 

instance (Monoid e, Error e, MonadIO m) => MonadIO (ErrorsT e m) where
  liftIO = lift . liftIO

instance (Monoid e, Error e, MonadErrors e m) => MonadErrors e (ReaderT r m) where
  annotate f = mapReaderT (annotate f)
  recover x = mapReaderT (recover x)

{-

instance MonadErrors e m => MonadErrors e (ReaderT r m) where
  report msg = lift (report msg) 
  abort = lift abort
  annotate = mapReaderT . annotate  

instance (Monoid e, Error e, MonadReader r m) => MonadReader r (ErrorsT e m) where
  ask = lift ask
  local f (ErrorsT p) = ErrorsT $ local f p

-}
