module Control.Monad.Ghc ( Ghc, runGhc,
                           GhcT, runGhcT,
                           GHC.GhcMonad(..),
                           module Control.Monad.Trans )

where

import Prelude hiding ( catch )

import Control.Monad.Trans
import qualified Control.Monad.Trans as MTL
import Control.Monad.CatchIO

import qualified GHC ( runGhc, runGhcT )
import qualified HscTypes   as GHC
import qualified MonadUtils as GHC
import qualified Exception  as GHC

newtype Ghc a = Ghc (GHC.Ghc a)
    deriving (Functor, Monad,
              GHC.WarnLogMonad, GHC.ExceptionMonad, GHC.MonadIO, GHC.GhcMonad)

instance MTL.MonadIO Ghc where
    liftIO = GHC.liftIO

instance MonadCatchIO Ghc where
    catch   = GHC.gcatch
    block   = GHC.gblock
    unblock = GHC.gunblock

runGhc :: Maybe FilePath -> Ghc a -> IO a
runGhc f (Ghc m) = GHC.runGhc f m

newtype GhcT m a = GhcT { unGhcT :: GHC.GhcT (MTLAdapter m) a }
                 deriving (Functor, Monad)

runGhcT :: (Functor m, MonadCatchIO m) => Maybe FilePath -> GhcT m a -> m a
runGhcT f = unWrap . GHC.runGhcT f . unGhcT

instance MTL.MonadTrans GhcT where
    lift = GhcT . GHC.liftGhcT . MTLAdapter

instance MTL.MonadIO m => MTL.MonadIO (GhcT m) where
    liftIO = GhcT . GHC.liftIO

instance MTL.MonadIO m => GHC.MonadIO (GhcT m) where
    liftIO = MTL.liftIO

instance MonadCatchIO m => MonadCatchIO (GhcT m) where
    m `catch` f = GhcT $ (unGhcT m) `GHC.gcatch` (unGhcT . f)
    block       = GhcT . GHC.gblock   . unGhcT
    unblock     = GhcT . GHC.gunblock . unGhcT

instance MonadCatchIO m => GHC.ExceptionMonad (GhcT m) where
    gcatch   = catch
    gblock   = block
    gunblock = unblock

instance MTL.MonadIO m => GHC.WarnLogMonad (GhcT m) where
    setWarnings = GhcT . GHC.setWarnings
    getWarnings = GhcT GHC.getWarnings

instance (Functor m, MonadCatchIO m) => GHC.GhcMonad (GhcT m) where
    getSession = GhcT GHC.getSession
    setSession = GhcT . GHC.setSession

-- | We use the 'MTLAdapter' to convert between similar classes
--   like 'MTL'''s 'MonadIO' and 'GHC'''s 'MonadIO'.
newtype MTLAdapter m a = MTLAdapter {unWrap :: m a} deriving (Functor, Monad)


instance MTL.MonadIO m => GHC.MonadIO (MTLAdapter m) where
    liftIO = MTLAdapter . MTL.liftIO

instance MonadCatchIO m => GHC.ExceptionMonad (MTLAdapter m) where
  m `gcatch` f = MTLAdapter $ (unWrap m) `catch` (unWrap . f)
  gblock       = MTLAdapter. block   . unWrap
  gunblock     = MTLAdapter. unblock . unWrap