ghc-mtl 1.0.1.2 → 1.1.0.0
raw patch · 2 files changed
+96/−32 lines, 2 filesdep +exceptionsdep +extensible-exceptionsdep −MonadCatchIO-mtldep ~basedep ~ghcdep ~mtl
Dependencies added: exceptions, extensible-exceptions
Dependencies removed: MonadCatchIO-mtl
Dependency ranges changed: base, ghc, mtl
Files
- Control/Monad/Ghc.hs +91/−28
- ghc-mtl.cabal +5/−4
Control/Monad/Ghc.hs view
@@ -9,10 +9,15 @@ import Prelude hiding ( catch ) #endif +import qualified Control.Exception.Extensible as E++import Control.Applicative+import Control.Monad import Control.Monad.Trans import qualified Control.Monad.Trans as MTL-import Control.Monad.CatchIO +import Control.Monad.Catch+ import qualified GHC ( runGhc, runGhcT ) import qualified MonadUtils as GHC import qualified Exception as GHC@@ -26,75 +31,133 @@ import qualified DynFlags as GHC #endif -newtype Ghc a = Ghc (GHC.Ghc a)- deriving (Functor, Monad,+newtype Ghc a = Ghc{ unGhc :: GHC.Ghc a }+ deriving (Functor+ ,Monad #if __GLASGOW_HASKELL__ < 702- GHC.WarnLogMonad,+ ,GHC.WarnLogMonad #elif __GLASGOW_HASKELL__ >= 706- GHC.HasDynFlags,+ ,GHC.HasDynFlags #endif- GHC.ExceptionMonad, GHC.MonadIO, GHC.GhcMonad)+ ,GHC.ExceptionMonad+#if __GLASGOW_HASKELL__ < 708+ ,GHC.MonadIO+#else+ ,MTL.MonadIO+ ,Applicative+#endif+ ,GHC.GhcMonad) ++#if __GLASGOW_HASKELL__ < 708+instance Applicative Ghc where+ pure = return+ (<*>) = ap+ instance MTL.MonadIO Ghc where liftIO = GHC.liftIO+#endif -instance MonadCatchIO Ghc where+instance MonadCatch Ghc where+ throwM = liftIO . E.throwIO catch = GHC.gcatch- block = GHC.gblock- unblock = GHC.gunblock +#if __GLASGOW_HASKELL__ >= 700+ -- @gmask@ is available...+ -- ...but it doesn't have a rank-n type like @mask@, so we need+ -- to use @Control.Exception.mask@ directly... (sigh)+ -- (this is type-directed, write only code)+ mask f = wrap $ \s ->+ mask $ \io_restore ->+ unwrap (f $ \m -> (wrap $ \s' -> io_restore (unwrap m s'))) s+ where+ wrap = Ghc . GHC.Ghc+ unwrap = GHC.unGhc . unGhc+#else+ -- this implementation, of course, offers less guarantees than the real @mask@,+ -- but we have no @mask@ available in the first place!+ mask io = GHC.gblock $ io GHC.gunblock+#endif++ uninterruptibleMask = mask+ 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,+ deriving (Functor+ ,Monad #if __GLASGOW_HASKELL__ >= 706- GHC.HasDynFlags,+ ,GHC.HasDynFlags #endif- Monad)+ ) -runGhcT :: (Functor m, MonadCatchIO m) => Maybe FilePath -> GhcT m a -> m a-runGhcT f = unWrap . GHC.runGhcT f . unGhcT+instance (Functor m, Monad m) => Applicative (GhcT m) where+ pure = return+ (<*>) = ap +runGhcT :: (Functor m, MonadIO m, MonadCatch m) => Maybe FilePath -> GhcT m a -> m a+runGhcT f = unMTLA . 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 +#if __GLASGOW_HASKELL__ < 708+ -- ghc started using transformers at some point instance MTL.MonadIO m => GHC.MonadIO (GhcT m) where liftIO = MTL.liftIO+#endif -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 (MonadIO m,MonadCatch m) => MonadCatch (GhcT m) where+ throwM = lift . throwM -instance MonadCatchIO m => GHC.ExceptionMonad (GhcT m) where- gcatch = catch- gblock = block- gunblock = unblock+ m `catch` f = GhcT ((unGhcT m) `GHC.gcatch` (unGhcT . f)) + mask f = wrap $ \s ->+ mask $ \io_restore ->+ unwrap (f $ \m -> (wrap $ \s' -> io_restore (unwrap m s'))) s+ where+ wrap g = GhcT $ GHC.GhcT $ \s -> MTLAdapter (g s)+ unwrap m = \s -> unMTLA ((GHC.unGhcT $ unGhcT $ m) s)++ uninterruptibleMask = mask++instance (MonadIO m, MonadCatch m) => GHC.ExceptionMonad (GhcT m) where+ gcatch = catch+#if __GLASGOW_HASKELL__ >= 700+ gmask f = mask (\x -> f x)+#else+ gblock = mask_+#endif++ #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+instance (Functor m, MonadIO m, MonadCatch 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)+newtype MTLAdapter m a = MTLAdapter {unMTLA :: m a} deriving (Functor, Applicative, 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 +instance (MonadIO m, MonadCatch m) => GHC.ExceptionMonad (MTLAdapter m) where+ m `gcatch` f = MTLAdapter $ (unMTLA m) `catch` (unMTLA . f)++#if __GLASGOW_HASKELL__ >= 700+ gmask io = MTLAdapter $ mask (\f -> unMTLA $ io (MTLAdapter . f . unMTLA))+#else+ gblock = MTLAdapter . mask_ . unMTLA -- use block instead+#endif
ghc-mtl.cabal view
@@ -1,5 +1,5 @@ name: ghc-mtl-version: 1.0.1.2+version: 1.1.0.0 description: Provides an 'mtl' compatible version of the 'GhcT' monad-transformer defined in the 'GHC-API' since version 6.10.1.@@ -10,9 +10,9 @@ license-file: LICENSE author: Daniel Gorin maintainer: jcpetruzza@gmail.com-homepage: http://darcsden.com/jcpetruzza/ghc-mtl+homepage: http://hub.darcs.net/jcpetruzza/ghc-mtl -cabal-version: >= 1.2+cabal-version: >= 1.6 build-type: Simple tested-with: GHC==6.10 @@ -20,7 +20,8 @@ build-depends: base >= 4, base <= 5, ghc >= 6.10, mtl,- MonadCatchIO-mtl >= 0.2.0.0+ exceptions == 0.3.*,+ extensible-exceptions exposed-modules: Control.Monad.Ghc extensions: GeneralizedNewtypeDeriving, CPP ghc-options: -Wall -O2