Commit fd3b845c authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺
Browse files

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
parent 9f4ca5af
......@@ -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)
......
{-# 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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment