Commit 06c6d970 authored by Ian Lynagh's avatar Ian Lynagh

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.
parent 0c047a83
......@@ -21,7 +21,7 @@
module CmmParse ( parseCmmFile ) where
import CgMonad hiding (getDynFlags)
import CgMonad
import CgExtCode
import CgHeapery
import CgUtils
......
......@@ -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
......
......@@ -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
......
......@@ -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 ->
......
......@@ -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
......
......@@ -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'
......
......@@ -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
......
......@@ -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
......
......@@ -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'
......
......@@ -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)
......
......@@ -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
......
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