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.

11 files changed, 33 insertions, 22 deletions

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 4e315ddbdf..e0d3da8a62 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 302d8ac652..6636e24ec1 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 cab0897fe8..71457c530c 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 e7ced1802e..0e8990777b 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 de844ea3b5..8e2b714ccd 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 816cc4b922..6b8c7bacdf 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 b4cfbf403f..f3df384618 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 f235465758..21984eced9 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 1e4def3f14..ab69916b1d 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 2c38b2ffde..60efee53fb 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 55d8946c4f..41b9c724b6 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