Make HasDynFlags more transformers friendly

Ideally, we'd have the more general

    instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where
        getDynFlags = lift getDynFlags

definition. However, that one would overlap with the `HasDynFlags (GhcT m)`
instance. Instead we define instances for a couple of common Monad
transformers explicitly in order to avoid nasty overlapping instances.

This is a preparatory refactoring for #10874

Reviewed By: austin

Differential Revision: https://phabricator.haskell.org/D1581

4 files changed, 44 insertions, 13 deletions

diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 539e2220b7..0aec7ad2a3 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -275,7 +275,7 @@ genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do
 -- some extra parameters.
 genCall t@(PrimTarget op) [] args
  | Just align <- machOpMemcpyishAlign op = runStmtsDecls $ do
-    dflags <- lift $ getDynFlags
+    dflags <- getDynFlags
     let isVolTy = [i1]
         isVolVal = [mkIntLit i1 0]
         argTy | MO_Memset _ <- op = [i8Ptr, i8,    llvmWord dflags, i32] ++ isVolTy
@@ -377,7 +377,7 @@ genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] =
 
 -- Handle all other foreign calls and prim ops.
 genCall target res args = runStmtsDecls $ do
-    dflags <- lift $ getDynFlags
+    dflags <- getDynFlags
 
     -- parameter types
     let arg_type (_, AddrHint) = i8Ptr
@@ -1378,7 +1378,7 @@ genMachOp_slow opt op [x, y] = case op of
 
                 else do
                     -- Error. Continue anyway so we can debug the generated ll file.
-                    dflags <- lift getDynFlags
+                    dflags <- getDynFlags
                     let style = mkCodeStyle CStyle
                         toString doc = renderWithStyle dflags doc style
                         cmmToStr = (lines . toString . PprCmm.pprExpr)
@@ -1422,7 +1422,7 @@ genMachOp_slow opt op [x, y] = case op of
             vx <- exprToVarW x
             vy <- exprToVarW y
 
-            dflags <- lift getDynFlags
+            dflags <- getDynFlags
             let word  = getVarType vx
             let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx)
             let shift = llvmWidthInBits dflags word
@@ -1522,7 +1522,7 @@ genLoad_fast atomic e r n ty = do
 genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
 genLoad_slow atomic e ty meta = runExprData $ do
     iptr <- exprToVarW e
-    dflags <- lift getDynFlags
+    dflags <- getDynFlags
     case getVarType iptr of
          LMPointer _ -> do
                     doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr)
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 3d99a1a5c0..c492a01332 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 -------------------------------------------------------------------------------
 --
@@ -176,6 +177,13 @@ import System.IO.Unsafe ( unsafePerformIO )
 import Data.IORef
 import Control.Arrow ((&&&))
 import Control.Monad
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Writer
+import Control.Monad.Trans.Reader
+import qualified Control.Monad.Trans.Maybe as CMT
+#if MIN_VERSION_transformers(4,0,0)
+import Control.Monad.Trans.Except
+#endif
 import Control.Exception (throwIO)
 
 import Data.Bits
@@ -186,6 +194,7 @@ import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Data.Monoid (Monoid)
 import Data.Word
 import System.FilePath
 import System.Directory
@@ -912,6 +921,32 @@ data DynFlags = DynFlags {
 class HasDynFlags m where
     getDynFlags :: m DynFlags
 
+{- It would be desirable to have the more generalised
+
+  instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where
+      getDynFlags = lift getDynFlags
+
+instance definition. However, that definition would overlap with the
+`HasDynFlags (GhcT m)` instance. Instead we define instances for a
+couple of common Monad transformers explicitly. -}
+
+instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where
+    getDynFlags = lift getDynFlags
+
+instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where
+    getDynFlags = lift getDynFlags
+
+instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where
+    getDynFlags = liftMaybeT getDynFlags
+
+instance (Monad m, HasDynFlags m) => HasDynFlags (CMT.MaybeT m) where
+    getDynFlags = lift getDynFlags
+
+#if MIN_VERSION_transformers(4,0,0)
+instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where
+    getDynFlags = lift getDynFlags
+#endif
+
 class ContainsDynFlags t where
     extractDynFlags :: t -> DynFlags
     replaceDynFlags :: t -> DynFlags -> t
diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs
index 44f9effdaa..34d5bcf91f 100644
--- a/compiler/main/GhcMonad.hs
+++ b/compiler/main/GhcMonad.hs
@@ -29,6 +29,7 @@ import DynFlags
 import Exception
 import ErrUtils
 
+import Control.Monad
 import Data.IORef
 
 -- -----------------------------------------------------------------------------
@@ -184,13 +185,8 @@ instance ExceptionMonad m => ExceptionMonad (GhcT m) where
                            in
                               unGhcT (f g_restore) s
 
-#if __GLASGOW_HASKELL__ < 710
--- Pre-AMP change
-instance (ExceptionMonad m, Functor m) => HasDynFlags (GhcT m) where
-#else
-instance (ExceptionMonad m) => HasDynFlags (GhcT m) where
-#endif
-  getDynFlags = getSessionDynFlags
+instance MonadIO m => HasDynFlags (GhcT m) where
+  getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r)
 
 #if __GLASGOW_HASKELL__ < 710
 -- Pre-AMP change
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 02a8670ef1..7fd9c8b1ab 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -849,7 +849,7 @@ runOneCommand eh gCmd = do
 checkInputForLayout :: String -> InputT GHCi (Maybe String)
                     -> InputT GHCi (Maybe String)
 checkInputForLayout stmt getStmt = do
-   dflags' <- lift $ getDynFlags
+   dflags' <- getDynFlags
    let dflags = xopt_set dflags' Opt_AlternativeLayoutRule
    st0 <- getGHCiState
    let buf'   =  stringToStringBuffer stmt