1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
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 MonadUtils as GHC
import qualified Exception as GHC
#if __GLASGOW_HASKELL__ >= 702
import qualified GhcMonad as GHC
#else
import qualified HscTypes as GHC
#endif
newtype Ghc a = Ghc (GHC.Ghc a)
deriving (Functor, Monad,
#if __GLASGOW_HASKELL__ < 702
GHC.WarnLogMonad,
#endif
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
#if __GLASGOW_HASKELL__ < 702
instance MTL.MonadIO m => GHC.WarnLogMonad (GhcT m) where
setWarnings = GhcT . GHC.setWarnings
getWarnings = GhcT GHC.getWarnings
#endif
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
|
