hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix MonadIO mess

Browse Source
This commit is contained in:
Daniel Gröber 2015-04-03 01:15:12 +02:00
parent f3b4da7a0e
commit d0ca3ee807
7 changed files with 72 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Language/Haskell/GhcMod/CaseSplit.hs
View File

@ -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

1
Language/Haskell/GhcMod/Error.hs
View File

@ -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

3
Language/Haskell/GhcMod/FillSig.hs
View File

@ -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

2
Language/Haskell/GhcMod/HomeModuleGraph.hs
View File

@ -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)

7
Language/Haskell/GhcMod/Logger.hs
View File

@ -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)
----------------------------------------------------------------

79
Language/Haskell/GhcMod/Monad/Types.hs
View File

@ -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

23
Language/Haskell/GhcMod/Types.hs
View File

@ -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)