Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/06c6d9709fb73cbaf9c0e1da337c5467c2839f0a >--------------------------------------------------------------- commit 06c6d9709fb73cbaf9c0e1da337c5467c2839f0a Author: Ian Lynagh <[email protected]> Date: Mon Dec 19 15:50:47 2011 +0000 Add a class HasDynFlags(getDynFlags) We no longer have many separate, clashing getDynFlags functions I've given each GhcMonad its own HasDynFlags instance, rather than using UndecidableInstances to make a GhcMonad m => HasDynFlags m instance. >--------------------------------------------------------------- compiler/cmm/CmmParse.y | 2 +- compiler/codeGen/CgMonad.lhs | 4 ++-- compiler/codeGen/StgCmmMonad.hs | 4 ++-- compiler/main/DriverPipeline.hs | 4 ++-- compiler/main/DynFlags.hs | 4 ++++ compiler/main/GhcMonad.hs | 9 +++++++-- compiler/main/HscMain.hs | 6 +++--- compiler/parser/Lexer.x | 4 ++-- compiler/simplCore/CoreMonad.lhs | 4 ++-- compiler/typecheck/TcSMonad.lhs | 4 ++-- ghc/GhciMonad.hs | 10 ++++++---- 11 files changed, 33 insertions(+), 22 deletions(-) diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 4e315dd..e0d3da8 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -21,7 +21,7 @@ module CmmParse ( parseCmmFile ) where -import CgMonad hiding (getDynFlags) +import CgMonad import CgExtCode import CgHeapery import CgUtils diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index 302d8ac..6636e24 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -502,8 +502,8 @@ newUnique = do getInfoDown :: FCode CgInfoDownwards getInfoDown = FCode $ \info_down state -> (info_down,state) -getDynFlags :: FCode DynFlags -getDynFlags = liftM cgd_dflags getInfoDown +instance HasDynFlags FCode where + getDynFlags = liftM cgd_dflags getInfoDown getThisPackage :: FCode PackageId getThisPackage = liftM thisPackage getDynFlags diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index cab0897..71457c5 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -379,8 +379,8 @@ newUnique = do getInfoDown :: FCode CgInfoDownwards getInfoDown = FCode $ \info_down state -> (info_down,state) -getDynFlags :: FCode DynFlags -getDynFlags = liftM cgd_dflags getInfoDown +instance HasDynFlags FCode where + getDynFlags = liftM cgd_dflags getInfoDown getThisPackage :: FCode PackageId getThisPackage = liftM thisPackage getDynFlags diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index e7ced18..0e89907 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -595,8 +595,8 @@ getPipeEnv = P $ \env state -> return (state, env) getPipeState :: CompPipeline PipeState getPipeState = P $ \_env state -> return (state, state) -getDynFlags :: CompPipeline DynFlags -getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) +instance HasDynFlags CompPipeline where + getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) setDynFlags :: DynFlags -> CompPipeline () setDynFlags dflags = P $ \_env state -> diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index de844ea..8e2b714 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -29,6 +29,7 @@ module DynFlags ( xopt_set, xopt_unset, DynFlags(..), + HasDynFlags(..), RtsOptsEnabled(..), HscTarget(..), isObjectTarget, defaultObjectTarget, GhcMode(..), isOneShot, @@ -585,6 +586,9 @@ data DynFlags = DynFlags { profAuto :: ProfAuto } +class HasDynFlags m where + getDynFlags :: m DynFlags + data ProfAuto = NoProfAuto -- ^ no SCC annotations added | ProfAutoAll -- ^ top-level and nested functions are annotated diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs index 816cc4b..6b8c7ba 100644 --- a/compiler/main/GhcMonad.hs +++ b/compiler/main/GhcMonad.hs @@ -46,11 +46,10 @@ import Data.IORef -- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' -- before any call to the GHC API functions can occur. -- -class (Functor m, MonadIO m, ExceptionMonad m) => GhcMonad m where +class (Functor m, MonadIO m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where getSession :: m HscEnv setSession :: HscEnv -> m () - -- | Call the argument with the current session. withSession :: GhcMonad m => (HscEnv -> m a) -> m a withSession f = getSession >>= f @@ -120,6 +119,9 @@ instance ExceptionMonad Ghc where in unGhc (f g_restore) s +instance HasDynFlags Ghc where + getDynFlags = getSessionDynFlags + instance GhcMonad Ghc where getSession = Ghc $ \(Session r) -> readIORef r setSession s' = Ghc $ \(Session r) -> writeIORef r s' @@ -176,6 +178,9 @@ instance ExceptionMonad m => ExceptionMonad (GhcT m) where in unGhcT (f g_restore) s +instance (Functor m, ExceptionMonad m, MonadIO m) => HasDynFlags (GhcT m) where + getDynFlags = getSessionDynFlags + instance (Functor m, ExceptionMonad m, MonadIO m) => GhcMonad (GhcT m) where getSession = GhcT $ \(Session r) -> liftIO $ readIORef r setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s' diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index b4cfbf4..f3df384 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -93,7 +93,7 @@ import HsSyn import CoreSyn import StringBuffer import Parser -import Lexer hiding (getDynFlags) +import Lexer import SrcLoc import TcRnDriver import TcIface ( typecheckIface ) @@ -223,8 +223,8 @@ logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) getHscEnv :: Hsc HscEnv getHscEnv = Hsc $ \e w -> return (e, w) -getDynFlags :: Hsc DynFlags -getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) +instance HasDynFlags Hsc where + getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) handleWarnings :: Hsc () handleWarnings = do diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index f235465..21984ec 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -1562,8 +1562,8 @@ failSpanMsgP span msg = P $ \_ -> PFailed span msg getPState :: P PState getPState = P $ \s -> POk s s -getDynFlags :: P DynFlags -getDynFlags = P $ \s -> POk s (dflags s) +instance HasDynFlags P where + getDynFlags = P $ \s -> POk s (dflags s) withThisPackage :: (PackageId -> a) -> P a withThisPackage f diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index 1e4def3..ab69916 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -865,8 +865,8 @@ addSimplCount count = write (CoreWriter { cw_simpl_count = count }) -- Convenience accessors for useful fields of HscEnv -getDynFlags :: CoreM DynFlags -getDynFlags = fmap hsc_dflags getHscEnv +instance HasDynFlags CoreM where + getDynFlags = fmap hsc_dflags getHscEnv -- | The original name cache is the current mapping from 'Module' and -- 'OccName' to a compiler-wide unique 'Name' diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 2c38b2f..60efee5 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -1010,8 +1010,8 @@ emitFrozenError fl ev depth inerts_new = inerts { inert_frozen = extendCts (inert_frozen inerts) ct } ; wrapTcS (TcM.writeTcRef inert_ref inerts_new) } -getDynFlags :: TcS DynFlags -getDynFlags = wrapTcS TcM.getDOpts +instance HasDynFlags TcS where + getDynFlags = wrapTcS TcM.getDOpts getTcSContext :: TcS SimplContext getTcSContext = TcS (return . tcs_context) diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index 55d8946..41b9c72 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -183,10 +183,16 @@ instance MonadUtils.MonadIO GHCi where instance Trans.MonadIO Ghc where liftIO = MonadUtils.liftIO +instance HasDynFlags GHCi where + getDynFlags = getSessionDynFlags + instance GhcMonad GHCi where setSession s' = liftGhc $ setSession s' getSession = liftGhc $ getSession +instance HasDynFlags (InputT GHCi) where + getDynFlags = lift getDynFlags + instance GhcMonad (InputT GHCi) where setSession = lift . setSession getSession = lift getSession @@ -221,10 +227,6 @@ instance ExceptionMonad (InputT GHCi) where gblock = Haskeline.block gunblock = Haskeline.unblock -getDynFlags :: GhcMonad m => m DynFlags -getDynFlags = do - GHC.getSessionDynFlags - setDynFlags :: DynFlags -> GHCi [PackageId] setDynFlags dflags = do GHC.setSessionDynFlags dflags _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
