From d0ca3ee807e9a9f2f035e692ba20151254adfd4a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Fri, 3 Apr 2015 01:15:12 +0200 Subject: [PATCH] Fix MonadIO mess --- Language/Haskell/GhcMod/CaseSplit.hs | 3 +- Language/Haskell/GhcMod/Error.hs | 1 - Language/Haskell/GhcMod/FillSig.hs | 3 +- Language/Haskell/GhcMod/HomeModuleGraph.hs | 2 +- Language/Haskell/GhcMod/Logger.hs | 7 +- Language/Haskell/GhcMod/Monad/Types.hs | 79 ++++++++++++---------- Language/Haskell/GhcMod/Types.hs | 23 +++++-- 7 files changed, 72 insertions(+), 46 deletions(-) diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index 0a5c810..77603ca 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -195,7 +195,8 @@ showFieldNames dflag style v (x:xs) = let fName = showName dflag style x ---------------------------------------------------------------- -- c. Code for performing the case splitting -genCaseSplitTextFile :: GhcMonad m => FilePath -> SplitToTextInfo -> m String +genCaseSplitTextFile :: (MonadIO m, GhcMonad m) => + FilePath -> SplitToTextInfo -> m String genCaseSplitTextFile file info = liftIO $ do t <- T.readFile file return $ getCaseSplitText (T.lines t) info diff --git a/Language/Haskell/GhcMod/Error.hs b/Language/Haskell/GhcMod/Error.hs index cefdc0e..965aa7e 100644 --- a/Language/Haskell/GhcMod/Error.hs +++ b/Language/Haskell/GhcMod/Error.hs @@ -49,7 +49,6 @@ import Config (cProjectVersion, cHostPlatformString) import Paths_ghc_mod (version) import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Pretty type GmError m = MonadError GhcModError m diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index 092248a..94f324c 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -167,7 +167,8 @@ getSignature modSum lineNo colNo = do return $ InstanceDecl loc cls -- Get signature from haskell-src-exts -getSignatureFromHE :: GhcMonad m => FilePath -> Int -> Int -> m (Maybe HESigInfo) +getSignatureFromHE :: (MonadIO m, GhcMonad m) => + FilePath -> Int -> Int -> m (Maybe HESigInfo) getSignatureFromHE file lineNo colNo = do presult <- liftIO $ HE.parseFile file return $ case presult of diff --git a/Language/Haskell/GhcMod/HomeModuleGraph.hs b/Language/Haskell/GhcMod/HomeModuleGraph.hs index 37ec5b1..09bfc08 100644 --- a/Language/Haskell/GhcMod/HomeModuleGraph.hs +++ b/Language/Haskell/GhcMod/HomeModuleGraph.hs @@ -36,9 +36,9 @@ import Exception import Finder import GHC import HscTypes -import MonadUtils hiding (foldrM) import Control.Arrow ((&&&)) +import Control.Applicative ((<$>)) import Control.Monad import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.State.Strict (execStateT) diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index 088c251..cba6858 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -2,6 +2,7 @@ module Language.Haskell.GhcMod.Logger ( withLogger , withLogger' , checkErrorPrefix + , errsToStr ) where import Control.Arrow @@ -96,10 +97,10 @@ withLogger' env action = do -- | Converting 'SourceError' to 'String'. sourceError :: DynFlags -> PprStyle -> SourceError -> [String] -sourceError df st src_err = errBagToStrList df st $ srcErrorMessages src_err +sourceError df st src_err = errsToStr df st $ reverse $ bagToList $ srcErrorMessages src_err -errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String] -errBagToStrList df st = map (ppErrMsg df st) . reverse . bagToList +errsToStr :: DynFlags -> PprStyle -> [ErrMsg] -> [String] +errsToStr df st = map (ppErrMsg df st) ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Monad/Types.hs b/Language/Haskell/GhcMod/Monad/Types.hs index d211966..ab644db 100644 --- a/Language/Haskell/GhcMod/Monad/Types.hs +++ b/Language/Haskell/GhcMod/Monad/Types.hs @@ -78,6 +78,7 @@ import Control.Monad.Reader (ReaderT(..)) import Control.Monad.Error (ErrorT(..), MonadError(..)) import Control.Monad.State.Strict (StateT(..)) import Control.Monad.Trans.Journal (JournalT) +import Control.Monad.Trans.Maybe (MaybeT) import Control.Monad.Base (MonadBase(..), liftBase) import Control.Monad.Trans.Control @@ -87,14 +88,10 @@ import Control.Monad.Writer.Class import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Journal.Class (MonadJournal(..)) import Control.Monad.Trans.Class (MonadTrans(..)) - -#ifdef MONADIO_INSTANCES -import Control.Monad.Trans.Maybe (MaybeT) import Control.Monad.Error (Error(..)) -#endif +import qualified Control.Monad.IO.Class as MTL #if DIFFERENT_MONADIO -import qualified Control.Monad.IO.Class import Data.Monoid (Monoid) #endif @@ -105,7 +102,7 @@ import Data.Monoid import Data.IORef import Distribution.Helper -import MonadUtils (MonadIO(..)) +import qualified MonadUtils as GHC (MonadIO(..)) data GhcModEnv = GhcModEnv { gmOptions :: Options @@ -159,8 +156,9 @@ newtype GhcModT m a = GhcModT { , Alternative , Monad , MonadPlus + , MTL.MonadIO #if DIFFERENT_MONADIO - , Control.Monad.IO.Class.MonadIO + , GHC.MonadIO #endif , MonadError GhcModError ) @@ -172,9 +170,9 @@ newtype GmlT m a = GmlT { unGmlT :: GhcModT m a } , Monad , MonadPlus , MonadTrans - , MonadIO + , MTL.MonadIO #if DIFFERENT_MONADIO - , Control.Monad.IO.Class.MonadIO + , GHC.MonadIO #endif , MonadError GhcModError , GmEnv @@ -186,12 +184,43 @@ newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a } deriving ( Functor , Applicative , Monad - , MonadIO + , MTL.MonadIO #if DIFFERENT_MONADIO - , Control.Monad.IO.Class.MonadIO + , GHC.MonadIO #endif ) +#if DIFFERENT_MONADIO +instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where + liftIO = MTL.liftIO +instance MTL.MonadIO m => GHC.MonadIO (StateT x m) where + liftIO = MTL.liftIO +instance (Error e, MTL.MonadIO m) => GHC.MonadIO (ErrorT e m) where + liftIO = MTL.liftIO +instance MTL.MonadIO m => GHC.MonadIO (JournalT x m) where + liftIO = MTL.liftIO +instance MTL.MonadIO m => GHC.MonadIO (MaybeT m) where + liftIO = MTL.liftIO +#endif + +instance MonadIO IO where + liftIO = id +instance MonadIO m => MonadIO (ReaderT x m) where + liftIO = MTL.liftIO +instance MonadIO m => MonadIO (StateT x m) where + liftIO = MTL.liftIO +instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where + liftIO = MTL.liftIO +instance MonadIO m => MonadIO (JournalT x m) where + liftIO = MTL.liftIO +instance MonadIO m => MonadIO (MaybeT m) where + liftIO = MTL.liftIO +instance MonadIOC m => MonadIO (GhcModT m) where + liftIO = MTL.liftIO +instance MonadIOC m => MonadIO (GmlT m) where + liftIO = MTL.liftIO +instance MonadIO LightGhc where + liftIO = MTL.liftIO class Monad m => GmEnv m where gmeAsk :: m GhcModEnv @@ -263,9 +292,6 @@ instance (Monad m, GmLog m) => GmLog (StateT s m) where gmlHistory = lift gmlHistory gmlClear = lift gmlClear -instance MonadIO m => MonadIO (GhcModT m) where - liftIO action = GhcModT $ liftIO action - instance Monad m => MonadJournal GhcModLog (GhcModT m) where journal !w = GhcModT $ lift $ lift $ (journal w) history = GhcModT $ lift $ lift $ history @@ -291,23 +317,6 @@ instance MonadState s m => MonadState s (GhcModT m) where put = GhcModT . lift . lift . lift . put state = GhcModT . lift . lift . lift . state -#if MONADIO_INSTANCES -instance MonadIO m => MonadIO (StateT s m) where - liftIO = lift . liftIO - -instance MonadIO m => MonadIO (ReaderT r m) where - liftIO = lift . liftIO - -instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where - liftIO = lift . liftIO - -instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where - liftIO = lift . liftIO - -instance MonadIO m => MonadIO (MaybeT m) where - liftIO = lift . liftIO -#endif - instance (MonadBaseControl IO m) => MonadBase IO (GmlT m) where liftBase = GmlT . liftBase @@ -370,14 +379,14 @@ type GmGhc m = (IOish m, GhcMonad m) instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where getSession = do ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet - liftIO $ readIORef ref + GHC.liftIO $ readIORef ref setSession a = do ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet - liftIO $ flip writeIORef a ref + GHC.liftIO $ flip writeIORef a ref instance GhcMonad LightGhc where - getSession = (liftIO . readIORef) =<< LightGhc ask - setSession a = (liftIO . flip writeIORef a) =<< LightGhc ask + getSession = (GHC.liftIO . readIORef) =<< LightGhc ask + setSession a = (GHC.liftIO . flip writeIORef a) =<< LightGhc ask #if __GLASGOW_HASKELL__ >= 706 instance (MonadIO m, MonadBaseControl IO m) => HasDynFlags (GmlT m) where diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index dd2370d..6430b6b 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveGeneric, StandaloneDeriving, - DefaultSignatures #-} +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, + StandaloneDeriving, DefaultSignatures, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} module Language.Haskell.GhcMod.Types ( module Language.Haskell.GhcMod.Types @@ -10,6 +10,7 @@ module Language.Haskell.GhcMod.Types ( import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Error (Error(..)) +import qualified Control.Monad.IO.Class as MTL import Control.Exception (Exception) import Control.Applicative import Control.Arrow @@ -25,7 +26,9 @@ import Data.Maybe import Data.Typeable (Typeable) import Distribution.Helper import Exception (ExceptionMonad) -import MonadUtils (MonadIO) +#if __GLASGOW_HASKELL__ < 708 +import qualified MonadUtils as GHC (MonadIO(..)) +#endif import GHC (ModuleName, moduleNameString, mkModuleName) import PackageConfig (PackageConfig) import GHC.Generics @@ -38,6 +41,18 @@ import GHC.Generics -- the exported API so users have the option to use a custom inner monad. type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m) + +-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. +-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. +#if __GLASGOW_HASKELL__ < 708 +type MonadIOC m = (GHC.MonadIO m, MTL.MonadIO m) +#else +type MonadIOC m = (MTL.MonadIO m) +#endif + +class MonadIOC m => MonadIO m where + liftIO :: IO a -> m a + -- | Output style. data OutputStyle = LispStyle -- ^ S expression style. | PlainStyle -- ^ Plain textstyle. @@ -208,7 +223,7 @@ data GmComponent (t :: GmComponentType) eps = GmComponent { gmcEntrypoints :: eps, gmcSourceDirs :: [FilePath], gmcHomeModuleGraph :: GmModuleGraph - } deriving (Eq, Ord, Show, Read, Generic, Typeable, Functor) + } deriving (Eq, Ord, Show, Read, Generic, Functor) instance Serialize eps => Serialize (GmComponent t eps)