{-# LANGUAGE TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}

import Control.Monad.Trans

class (Eq e) => Throwable e where
    type OuterException e
    type OtherExceptions e
    getOuterException :: e -> OuterException e
    getOtherExceptions :: e -> OtherExceptions e
    noException :: e

instance Throwable () where
    type OuterException () = ()
    type OtherExceptions () = ()
    getOuterException () = ()
    getOtherExceptions () = ()
    noException = ()

instance (Throwable e1, Throwable e2) => Throwable (e1, e2) where
    type OuterException (e1, e2) = e2
    type OtherExceptions (e1, e2) = e1
    getOuterException (e1,e2) = e2
    getOtherExceptions (e1,e2) = e1
    noException = (noException, noException)

class (Throwable e, Throwable e1) => Contains e e1 where
    encapsulate :: e -> e1

instance (Throwable e) => Contains e e where
    encapsulate e = e

instance (Throwable e1, Throwable e2) => Contains e1 (e1, e2) where
    encapsulate e = (e, noException)

instance (Throwable e1, Throwable e2) => Contains e2 (e1, e2) where
    encapsulate e = (noException, e)

data (Throwable e) => Result e a = Throw e | Result a   

newtype (Monad m, Throwable e) => Throws e m a = Controller {
    runController :: m (Result e a)
    }

instance (Monad m, Throwable e) => Monad (Throws e m) where
    return v = Controller $ return (Result v)

    Controller cmd >>= f =
        Controller $ do       -- `do` in `m`
            res <- cmd
            case res of
                Throw resp -> return (Throw resp)
                Result res'   -> (runController . f) res'

instance (Throwable e) => MonadTrans (Throws e) where
    lift act = Controller $ do
        res <- act
        return (Result res)

catchExceptions ::  (Monad m, Contains e a1) => Throws e m a -> Throws a1 m a
catchExceptions cmd = Controller $ do
    res <- runController cmd
    case res of
        Throw e -> return (Throw $ encapsulate e)
        Result a -> return (Result a)

throw :: (Monad m, Throwable e, Throwable e1, Contains e e1) => e -> Throws e1 m a
throw e =  Controller $ return (Throw $ encapsulate e)

exceptAll :: (Monad m, Throwable e) => Throws e m a -> (e -> m a) -> m a
exceptAll m f = do
    res <- runController m
    case res of
        Throw e -> f e
        Result r -> return r

except :: (Monad m, Throwable e, Throwable (OtherExceptions e), Throwable (OuterException e))
                                 => Throws e m a
                                 -> (OuterException e -> Throws (OtherExceptions e) m a)
                                 -> Throws (OtherExceptions e) m a
except m f = do
    res <- lift $ runController m
    case res of
        Throw e -> let out = getOuterException e
                   in if out == noException 
                        then throw $ getOtherExceptions e
                        else f out
        Result a -> return a

try :: (Monad m) => Throws () m a -> m a
try m = do
    res <- runController m
    case res of
        Result a -> return a

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

data InvalidPointerException = IPE | NoIPE
    deriving (Eq, Show)

instance Throwable InvalidPointerException where
    type OuterException InvalidPointerException = InvalidPointerException
    type OtherExceptions InvalidPointerException = ()
    getOuterException IPE = IPE
    getOtherExceptions IPE = ()
    noException = NoIPE

data AnotherException = AnotherException | NoAE
    deriving (Eq, Show)

instance Throwable AnotherException where
    type OuterException AnotherException = AnotherException
    type OtherExceptions AnotherException = ()
    getOuterException AnotherException = AnotherException
    getOtherExceptions AnotherException = ()
    noException = NoAE

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

test :: Int -> Throws InvalidPointerException IO String
test x = if x > 0
           then lift $ return $ show (x*x)
           else throw IPE

test2 :: Int -> Throws (AnotherException, InvalidPointerException) IO String
test2 x = if x < 7
            then do
                  y <- catchExceptions $ test x
                  return $ y++"!!"
            else throw AnotherException

main :: IO ()
main = do
--     y <- test2 (-1)
    y <- try $
            test2 (-1)
            `except`
              (\IPE -> return "Exception!")
            `except`
              \AnotherException -> return "Another exception!"
    print y