Hannes Siebenhandl pushed to branch wip/fendor/ghci-multiple-home-units at Glasgow Haskell Compiler / GHC
Commits:
20 changed files:
- compiler/GHC.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Rename/Unbound.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/StgToJS/Linker/Linker.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Home/Graph.hs
- compiler/GHC/Unit/Types.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Exception.hs
- ghc/GHCi/UI/Info.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
- testsuite/tests/linters/notes.stdout
Changes:
| ... | ... | @@ -38,7 +38,9 @@ module GHC ( |
| 38 | 38 | setSessionDynFlags,
|
| 39 | 39 | setUnitDynFlags,
|
| 40 | 40 | getProgramDynFlags, setProgramDynFlags,
|
| 41 | + setProgramHUG, setProgramHUG_,
|
|
| 41 | 42 | getInteractiveDynFlags, setInteractiveDynFlags,
|
| 43 | + normaliseInteractiveDynFlags, initialiseInteractiveDynFlags,
|
|
| 42 | 44 | interpretPackageEnv,
|
| 43 | 45 | |
| 44 | 46 | -- * Logging
|
| ... | ... | @@ -55,6 +57,7 @@ module GHC ( |
| 55 | 57 | addTarget,
|
| 56 | 58 | removeTarget,
|
| 57 | 59 | guessTarget,
|
| 60 | + guessTargetId,
|
|
| 58 | 61 | |
| 59 | 62 | -- * Loading\/compiling the program
|
| 60 | 63 | depanal, depanalE,
|
| ... | ... | @@ -83,6 +86,7 @@ module GHC ( |
| 83 | 86 | getModuleGraph,
|
| 84 | 87 | isLoaded,
|
| 85 | 88 | isLoadedModule,
|
| 89 | + isLoadedHomeModule,
|
|
| 86 | 90 | topSortModuleGraph,
|
| 87 | 91 | |
| 88 | 92 | -- * Inspecting modules
|
| ... | ... | @@ -155,6 +159,7 @@ module GHC ( |
| 155 | 159 | getBindings, getInsts, getNamePprCtx,
|
| 156 | 160 | findModule, lookupModule,
|
| 157 | 161 | findQualifiedModule, lookupQualifiedModule,
|
| 162 | + lookupLoadedHomeModuleByModuleName, lookupAllQualifiedModuleNames,
|
|
| 158 | 163 | renamePkgQualM, renameRawPkgQualM,
|
| 159 | 164 | isModuleTrusted, moduleTrustReqs,
|
| 160 | 165 | getNamesInScope,
|
| ... | ... | @@ -443,6 +448,7 @@ import Control.Concurrent |
| 443 | 448 | import Control.Monad
|
| 444 | 449 | import Control.Monad.Catch as MC
|
| 445 | 450 | import Data.Foldable
|
| 451 | +import Data.Function ((&))
|
|
| 446 | 452 | import Data.IORef
|
| 447 | 453 | import Data.List (isPrefixOf)
|
| 448 | 454 | import Data.Typeable ( Typeable )
|
| ... | ... | @@ -458,7 +464,7 @@ import System.Environment ( getEnv, getProgName ) |
| 458 | 464 | import System.Exit ( exitWith, ExitCode(..) )
|
| 459 | 465 | import System.FilePath
|
| 460 | 466 | import System.IO.Error ( isDoesNotExistError )
|
| 461 | -import GHC.Unit.Home.PackageTable
|
|
| 467 | + |
|
| 462 | 468 | |
| 463 | 469 | -- %************************************************************************
|
| 464 | 470 | -- %* *
|
| ... | ... | @@ -861,6 +867,113 @@ setProgramDynFlags_ invalidate_needed dflags = do |
| 861 | 867 | when invalidate_needed $ invalidateModSummaryCache
|
| 862 | 868 | return changed
|
| 863 | 869 | |
| 870 | +-- | Sets the program 'HomeUnitGraph'.
|
|
| 871 | +--
|
|
| 872 | +-- Sets the given 'HomeUnitGraph' as the 'HomeUnitGraph' of the current
|
|
| 873 | +-- session. If the package flags change, we reinitialise the 'UnitState'
|
|
| 874 | +-- of all 'HomeUnitEnv's in the current session.
|
|
| 875 | +--
|
|
| 876 | +-- This function unconditionally invalidates the module graph cache.
|
|
| 877 | +--
|
|
| 878 | +-- Precondition: the given 'HomeUnitGraph' must have the same keys as the 'HomeUnitGraph'
|
|
| 879 | +-- of the current session. I.e., assuming the new 'HomeUnitGraph' is called
|
|
| 880 | +-- 'new_hug', then:
|
|
| 881 | +--
|
|
| 882 | +-- @
|
|
| 883 | +-- do
|
|
| 884 | +-- hug <- hsc_HUG \<$\> getSession
|
|
| 885 | +-- pure $ unitEnv_keys new_hug == unitEnv_keys hug
|
|
| 886 | +-- @
|
|
| 887 | +--
|
|
| 888 | +-- If this precondition is violated, the function will crash.
|
|
| 889 | +--
|
|
| 890 | +-- Conceptually, similar to 'setProgramDynFlags', but performs the same check
|
|
| 891 | +-- for all 'HomeUnitEnv's.
|
|
| 892 | +setProgramHUG :: GhcMonad m => HomeUnitGraph -> m Bool
|
|
| 893 | +setProgramHUG =
|
|
| 894 | + setProgramHUG_ True
|
|
| 895 | + |
|
| 896 | +-- | Same as 'setProgramHUG', but gives you control over whether you want to
|
|
| 897 | +-- invalidate the module graph cache.
|
|
| 898 | +setProgramHUG_ :: GhcMonad m => Bool -> HomeUnitGraph -> m Bool
|
|
| 899 | +setProgramHUG_ invalidate_needed new_hug0 = do
|
|
| 900 | + logger <- getLogger
|
|
| 901 | + |
|
| 902 | + hug0 <- hsc_HUG <$> getSession
|
|
| 903 | + (changed, new_hug1) <- checkNewHugDynFlags logger hug0 new_hug0
|
|
| 904 | + |
|
| 905 | + if changed
|
|
| 906 | + then do
|
|
| 907 | + unit_env0 <- hsc_unit_env <$> getSession
|
|
| 908 | + home_unit_graph <- HUG.unitEnv_traverseWithKey
|
|
| 909 | + (updateHomeUnit logger unit_env0 new_hug1)
|
|
| 910 | + (ue_home_unit_graph unit_env0)
|
|
| 911 | + |
|
| 912 | + let dflags1 = homeUnitEnv_dflags $ HUG.unitEnv_lookup (ue_currentUnit unit_env0) home_unit_graph
|
|
| 913 | + let unit_env = UnitEnv
|
|
| 914 | + { ue_platform = targetPlatform dflags1
|
|
| 915 | + , ue_namever = ghcNameVersion dflags1
|
|
| 916 | + , ue_home_unit_graph = home_unit_graph
|
|
| 917 | + , ue_current_unit = ue_currentUnit unit_env0
|
|
| 918 | + , ue_eps = ue_eps unit_env0
|
|
| 919 | + }
|
|
| 920 | + modifySession $ \h ->
|
|
| 921 | + -- hscSetFlags takes care of updating the logger as well.
|
|
| 922 | + hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
|
|
| 923 | + else do
|
|
| 924 | + modifySession (\env ->
|
|
| 925 | + env
|
|
| 926 | + -- Set the new 'HomeUnitGraph'.
|
|
| 927 | + & hscUpdateHUG (const new_hug1)
|
|
| 928 | + -- hscSetActiveUnitId makes sure that the 'hsc_dflags'
|
|
| 929 | + -- are up-to-date.
|
|
| 930 | + & hscSetActiveUnitId (hscActiveUnitId env)
|
|
| 931 | + -- Make sure the logger is also updated.
|
|
| 932 | + & hscUpdateLoggerFlags)
|
|
| 933 | + |
|
| 934 | + when invalidate_needed $ invalidateModSummaryCache
|
|
| 935 | + pure changed
|
|
| 936 | + where
|
|
| 937 | + checkNewHugDynFlags :: GhcMonad m => Logger -> HomeUnitGraph -> HomeUnitGraph -> m (Bool, HomeUnitGraph)
|
|
| 938 | + checkNewHugDynFlags logger old_hug new_hug = do
|
|
| 939 | + -- Traverse the new HUG and check its 'DynFlags'.
|
|
| 940 | + -- The old 'HUG' is used to check whether package flags have changed.
|
|
| 941 | + hugWithCheck <- HUG.unitEnv_traverseWithKey
|
|
| 942 | + (\unitId homeUnit -> do
|
|
| 943 | + let newFlags = homeUnitEnv_dflags homeUnit
|
|
| 944 | + oldFlags = homeUnitEnv_dflags (HUG.unitEnv_lookup unitId old_hug)
|
|
| 945 | + checkedFlags <- checkNewDynFlags logger newFlags
|
|
| 946 | + pure
|
|
| 947 | + ( packageFlagsChanged oldFlags checkedFlags
|
|
| 948 | + , homeUnit { homeUnitEnv_dflags = checkedFlags }
|
|
| 949 | + )
|
|
| 950 | + )
|
|
| 951 | + new_hug
|
|
| 952 | + let
|
|
| 953 | + -- Did any of the package flags change?
|
|
| 954 | + changed = or $ fmap fst hugWithCheck
|
|
| 955 | + hug = fmap snd hugWithCheck
|
|
| 956 | + pure (changed, hug)
|
|
| 957 | + |
|
| 958 | + updateHomeUnit :: GhcMonad m => Logger -> UnitEnv -> HomeUnitGraph -> (UnitId -> HomeUnitEnv -> m HomeUnitEnv)
|
|
| 959 | + updateHomeUnit logger unit_env updates = \uid homeUnitEnv -> do
|
|
| 960 | + let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
|
|
| 961 | + dflags = case HUG.unitEnv_lookup_maybe uid updates of
|
|
| 962 | + Nothing -> homeUnitEnv_dflags homeUnitEnv
|
|
| 963 | + Just env -> homeUnitEnv_dflags env
|
|
| 964 | + old_hpt = homeUnitEnv_hpt homeUnitEnv
|
|
| 965 | + home_units = HUG.allUnits (ue_home_unit_graph unit_env)
|
|
| 966 | + |
|
| 967 | + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
|
|
| 968 | + |
|
| 969 | + updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
|
|
| 970 | + pure HomeUnitEnv
|
|
| 971 | + { homeUnitEnv_units = unit_state
|
|
| 972 | + , homeUnitEnv_unit_dbs = Just dbs
|
|
| 973 | + , homeUnitEnv_dflags = updated_dflags
|
|
| 974 | + , homeUnitEnv_hpt = old_hpt
|
|
| 975 | + , homeUnitEnv_home_unit = Just home_unit
|
|
| 976 | + }
|
|
| 864 | 977 | |
| 865 | 978 | -- When changing the DynFlags, we want the changes to apply to future
|
| 866 | 979 | -- loads, but without completely discarding the program. But the
|
| ... | ... | @@ -900,24 +1013,8 @@ getProgramDynFlags = getSessionDynFlags |
| 900 | 1013 | setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
|
| 901 | 1014 | setInteractiveDynFlags dflags = do
|
| 902 | 1015 | logger <- getLogger
|
| 903 | - dflags' <- checkNewDynFlags logger dflags
|
|
| 904 | - dflags'' <- checkNewInteractiveDynFlags logger dflags'
|
|
| 905 | - modifySessionM $ \hsc_env0 -> do
|
|
| 906 | - let ic0 = hsc_IC hsc_env0
|
|
| 907 | - |
|
| 908 | - -- Initialise (load) plugins in the interactive environment with the new
|
|
| 909 | - -- DynFlags
|
|
| 910 | - plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $
|
|
| 911 | - hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }}
|
|
| 912 | - |
|
| 913 | - -- Update both plugins cache and DynFlags in the interactive context.
|
|
| 914 | - return $ hsc_env0
|
|
| 915 | - { hsc_IC = ic0
|
|
| 916 | - { ic_plugins = hsc_plugins plugin_env
|
|
| 917 | - , ic_dflags = hsc_dflags plugin_env
|
|
| 918 | - }
|
|
| 919 | - }
|
|
| 920 | - |
|
| 1016 | + icdflags <- normaliseInteractiveDynFlags logger dflags
|
|
| 1017 | + modifySessionM (initialiseInteractiveDynFlags icdflags)
|
|
| 921 | 1018 | |
| 922 | 1019 | -- | Get the 'DynFlags' used to evaluate interactive expressions.
|
| 923 | 1020 | getInteractiveDynFlags :: GhcMonad m => m DynFlags
|
| ... | ... | @@ -1022,6 +1119,36 @@ normalise_hyp fp |
| 1022 | 1119 | |
| 1023 | 1120 | -----------------------------------------------------------------------------
|
| 1024 | 1121 | |
| 1122 | +-- | Normalise the 'DynFlags' for us in an interactive context.
|
|
| 1123 | +--
|
|
| 1124 | +-- Makes sure unsupported Flags and other incosistencies are reported and removed.
|
|
| 1125 | +normaliseInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags
|
|
| 1126 | +normaliseInteractiveDynFlags logger dflags = do
|
|
| 1127 | + dflags' <- checkNewDynFlags logger dflags
|
|
| 1128 | + checkNewInteractiveDynFlags logger dflags'
|
|
| 1129 | + |
|
| 1130 | +-- | Given a set of normalised 'DynFlags' (see 'normaliseInteractiveDynFlags')
|
|
| 1131 | +-- for the interactive context, initialize the 'InteractiveContext'.
|
|
| 1132 | +--
|
|
| 1133 | +-- Initialized plugins and sets the 'DynFlags' as the 'ic_dflags' of the
|
|
| 1134 | +-- 'InteractiveContext'.
|
|
| 1135 | +initialiseInteractiveDynFlags :: GhcMonad m => DynFlags -> HscEnv -> m HscEnv
|
|
| 1136 | +initialiseInteractiveDynFlags dflags hsc_env0 = do
|
|
| 1137 | + let ic0 = hsc_IC hsc_env0
|
|
| 1138 | + |
|
| 1139 | + -- Initialise (load) plugins in the interactive environment with the new
|
|
| 1140 | + -- DynFlags
|
|
| 1141 | + plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $
|
|
| 1142 | + hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags }}
|
|
| 1143 | + |
|
| 1144 | + -- Update both plugins cache and DynFlags in the interactive context.
|
|
| 1145 | + return $ hsc_env0
|
|
| 1146 | + { hsc_IC = ic0
|
|
| 1147 | + { ic_plugins = hsc_plugins plugin_env
|
|
| 1148 | + , ic_dflags = hsc_dflags plugin_env
|
|
| 1149 | + }
|
|
| 1150 | + }
|
|
| 1151 | + |
|
| 1025 | 1152 | -- | Checks the set of new DynFlags for possibly erroneous option
|
| 1026 | 1153 | -- combinations when invoking 'setSessionDynFlags' and friends, and if
|
| 1027 | 1154 | -- found, returns a fixed copy (if possible).
|
| ... | ... | @@ -1084,7 +1211,7 @@ removeTarget target_id |
| 1084 | 1211 | where
|
| 1085 | 1212 | filter targets = [ t | t@Target { targetId = id } <- targets, id /= target_id ]
|
| 1086 | 1213 | |
| 1087 | --- | Attempts to guess what Target a string refers to. This function
|
|
| 1214 | +-- | Attempts to guess what 'Target' a string refers to. This function
|
|
| 1088 | 1215 | -- implements the @--make@/GHCi command-line syntax for filenames:
|
| 1089 | 1216 | --
|
| 1090 | 1217 | -- - if the string looks like a Haskell source filename, then interpret it
|
| ... | ... | @@ -1093,27 +1220,52 @@ removeTarget target_id |
| 1093 | 1220 | -- - if adding a .hs or .lhs suffix yields the name of an existing file,
|
| 1094 | 1221 | -- then use that
|
| 1095 | 1222 | --
|
| 1096 | --- - otherwise interpret the string as a module name
|
|
| 1223 | +-- - If it looks like a module name, interpret it as such
|
|
| 1097 | 1224 | --
|
| 1225 | +-- - otherwise, this function throws a 'GhcException'.
|
|
| 1098 | 1226 | guessTarget :: GhcMonad m => String -> Maybe UnitId -> Maybe Phase -> m Target
|
| 1099 | 1227 | guessTarget str mUnitId (Just phase)
|
| 1100 | 1228 | = do
|
| 1101 | 1229 | tuid <- unitIdOrHomeUnit mUnitId
|
| 1102 | 1230 | return (Target (TargetFile str (Just phase)) True tuid Nothing)
|
| 1103 | -guessTarget str mUnitId Nothing
|
|
| 1231 | +guessTarget str mUnitId Nothing = do
|
|
| 1232 | + targetId <- guessTargetId str
|
|
| 1233 | + toTarget targetId
|
|
| 1234 | + where
|
|
| 1235 | + obj_allowed
|
|
| 1236 | + | '*':_ <- str = False
|
|
| 1237 | + | otherwise = True
|
|
| 1238 | + toTarget tid = do
|
|
| 1239 | + tuid <- unitIdOrHomeUnit mUnitId
|
|
| 1240 | + pure $ Target tid obj_allowed tuid Nothing
|
|
| 1241 | + |
|
| 1242 | +-- | Attempts to guess what 'TargetId' a string refers to. This function
|
|
| 1243 | +-- implements the @--make@/GHCi command-line syntax for filenames:
|
|
| 1244 | +--
|
|
| 1245 | +-- - if the string looks like a Haskell source filename, then interpret it
|
|
| 1246 | +-- as such
|
|
| 1247 | +--
|
|
| 1248 | +-- - if adding a .hs or .lhs suffix yields the name of an existing file,
|
|
| 1249 | +-- then use that
|
|
| 1250 | +--
|
|
| 1251 | +-- - If it looks like a module name, interpret it as such
|
|
| 1252 | +--
|
|
| 1253 | +-- - otherwise, this function throws a 'GhcException'.
|
|
| 1254 | +guessTargetId :: GhcMonad m => String -> m TargetId
|
|
| 1255 | +guessTargetId str
|
|
| 1104 | 1256 | | isHaskellSrcFilename file
|
| 1105 | - = target (TargetFile file Nothing)
|
|
| 1257 | + = pure (TargetFile file Nothing)
|
|
| 1106 | 1258 | | otherwise
|
| 1107 | 1259 | = do exists <- liftIO $ doesFileExist hs_file
|
| 1108 | 1260 | if exists
|
| 1109 | - then target (TargetFile hs_file Nothing)
|
|
| 1261 | + then pure (TargetFile hs_file Nothing)
|
|
| 1110 | 1262 | else do
|
| 1111 | 1263 | exists <- liftIO $ doesFileExist lhs_file
|
| 1112 | 1264 | if exists
|
| 1113 | - then target (TargetFile lhs_file Nothing)
|
|
| 1265 | + then pure (TargetFile lhs_file Nothing)
|
|
| 1114 | 1266 | else do
|
| 1115 | 1267 | if looksLikeModuleName file
|
| 1116 | - then target (TargetModule (mkModuleName file))
|
|
| 1268 | + then pure (TargetModule (mkModuleName file))
|
|
| 1117 | 1269 | else do
|
| 1118 | 1270 | dflags <- getDynFlags
|
| 1119 | 1271 | liftIO $ throwGhcExceptionIO
|
| ... | ... | @@ -1121,16 +1273,12 @@ guessTarget str mUnitId Nothing |
| 1121 | 1273 | text "target" <+> quotes (text file) <+>
|
| 1122 | 1274 | text "is not a module name or a source file"))
|
| 1123 | 1275 | where
|
| 1124 | - (file,obj_allowed)
|
|
| 1125 | - | '*':rest <- str = (rest, False)
|
|
| 1126 | - | otherwise = (str, True)
|
|
| 1276 | + file
|
|
| 1277 | + | '*':rest <- str = rest
|
|
| 1278 | + | otherwise = str
|
|
| 1127 | 1279 | |
| 1128 | - hs_file = file <.> "hs"
|
|
| 1129 | - lhs_file = file <.> "lhs"
|
|
| 1130 | - |
|
| 1131 | - target tid = do
|
|
| 1132 | - tuid <- unitIdOrHomeUnit mUnitId
|
|
| 1133 | - pure $ Target tid obj_allowed tuid Nothing
|
|
| 1280 | + hs_file = file <.> "hs"
|
|
| 1281 | + lhs_file = file <.> "lhs"
|
|
| 1134 | 1282 | |
| 1135 | 1283 | -- | Unwrap 'UnitId' or retrieve the 'UnitId'
|
| 1136 | 1284 | -- of the current 'HomeUnit'.
|
| ... | ... | @@ -1251,11 +1399,11 @@ type TypecheckedSource = LHsBinds GhcTc |
| 1251 | 1399 | --
|
| 1252 | 1400 | -- This function ignores boot modules and requires that there is only one
|
| 1253 | 1401 | -- non-boot module with the given name.
|
| 1254 | -getModSummary :: GhcMonad m => ModuleName -> m ModSummary
|
|
| 1402 | +getModSummary :: GhcMonad m => Module -> m ModSummary
|
|
| 1255 | 1403 | getModSummary mod = do
|
| 1256 | 1404 | mg <- liftM hsc_mod_graph getSession
|
| 1257 | 1405 | let mods_by_name = [ ms | ms <- mgModSummaries mg
|
| 1258 | - , ms_mod_name ms == mod
|
|
| 1406 | + , ms_mod ms == mod
|
|
| 1259 | 1407 | , isBootSummary ms == NotBoot ]
|
| 1260 | 1408 | case mods_by_name of
|
| 1261 | 1409 | [] -> do dflags <- getDynFlags
|
| ... | ... | @@ -1286,7 +1434,9 @@ typecheckModule pmod = do |
| 1286 | 1434 | liftIO $ do
|
| 1287 | 1435 | let ms = modSummary pmod
|
| 1288 | 1436 | let lcl_dflags = ms_hspp_opts ms -- take into account pragmas (OPTIONS_GHC, etc.)
|
| 1289 | - let lcl_hsc_env = hscSetFlags lcl_dflags hsc_env
|
|
| 1437 | + let lcl_hsc_env =
|
|
| 1438 | + hscSetFlags lcl_dflags $
|
|
| 1439 | + hscSetActiveUnitId (toUnitId $ moduleUnit $ ms_mod ms) hsc_env
|
|
| 1290 | 1440 | let lcl_logger = hsc_logger lcl_hsc_env
|
| 1291 | 1441 | (tc_gbl_env, rn_info) <- hscTypecheckRename lcl_hsc_env ms $
|
| 1292 | 1442 | HsParsedModule { hpm_module = parsedSource pmod,
|
| ... | ... | @@ -1431,14 +1581,24 @@ getModuleGraph = liftM hsc_mod_graph getSession |
| 1431 | 1581 | -- | Return @True@ \<==> module is loaded.
|
| 1432 | 1582 | isLoaded :: GhcMonad m => ModuleName -> m Bool
|
| 1433 | 1583 | isLoaded m = withSession $ \hsc_env -> liftIO $ do
|
| 1434 | - hmi <- lookupHpt (hsc_HPT hsc_env) m
|
|
| 1435 | - return $! isJust hmi
|
|
| 1584 | + hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m
|
|
| 1585 | + return $! not (null hmis)
|
|
| 1436 | 1586 | |
| 1587 | +-- | Check whether a 'ModuleName' is found in the 'HomePackageTable'
|
|
| 1588 | +-- for the given 'UnitId'.
|
|
| 1437 | 1589 | isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool
|
| 1438 | 1590 | isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do
|
| 1439 | 1591 | hmi <- HUG.lookupHug (hsc_HUG hsc_env) uid m
|
| 1440 | 1592 | return $! isJust hmi
|
| 1441 | 1593 | |
| 1594 | +-- | Check whether 'Module' is part of the 'HomeUnitGraph'.
|
|
| 1595 | +--
|
|
| 1596 | +-- Similar to 'isLoadedModule', but for 'Module's.
|
|
| 1597 | +isLoadedHomeModule :: GhcMonad m => Module -> m Bool
|
|
| 1598 | +isLoadedHomeModule m = withSession $ \hsc_env -> liftIO $ do
|
|
| 1599 | + hmi <- HUG.lookupHugByModule m (hsc_HUG hsc_env)
|
|
| 1600 | + return $! isJust hmi
|
|
| 1601 | + |
|
| 1442 | 1602 | -- | Return the bindings for the current interactive session.
|
| 1443 | 1603 | getBindings :: GhcMonad m => m [TyThing]
|
| 1444 | 1604 | getBindings = withSession $ \hsc_env ->
|
| ... | ... | @@ -1470,7 +1630,7 @@ data ModuleInfo = ModuleInfo { |
| 1470 | 1630 | -- | Request information about a loaded 'Module'
|
| 1471 | 1631 | getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X
|
| 1472 | 1632 | getModuleInfo mdl = withSession $ \hsc_env -> do
|
| 1473 | - if moduleUnitId mdl `S.member` hsc_all_home_unit_ids hsc_env
|
|
| 1633 | + if HUG.memberHugUnit (moduleUnit mdl) (hsc_HUG hsc_env)
|
|
| 1474 | 1634 | then liftIO $ getHomeModuleInfo hsc_env mdl
|
| 1475 | 1635 | else liftIO $ getPackageModuleInfo hsc_env mdl
|
| 1476 | 1636 | |
| ... | ... | @@ -1826,6 +1986,50 @@ lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> liftIO $ do |
| 1826 | 1986 | Just mod_info -> return (Just (mi_module (hm_iface mod_info)))
|
| 1827 | 1987 | _not_a_home_module -> return Nothing
|
| 1828 | 1988 | |
| 1989 | +-- | Lookup the given 'ModuleName' in the 'HomeUnitGraph'.
|
|
| 1990 | +--
|
|
| 1991 | +-- Returns 'Nothing' if no 'Module' has the given 'ModuleName'.
|
|
| 1992 | +-- Otherwise, returns all 'Module's that have the given 'ModuleName'.
|
|
| 1993 | +--
|
|
| 1994 | +-- A 'ModuleName' is generally not enough to uniquely identify a 'Module', since
|
|
| 1995 | +-- there can be multiple units exposing the same 'ModuleName' in the case of
|
|
| 1996 | +-- multiple home units.
|
|
| 1997 | +-- Thus, this function may return more than one possible 'Module'.
|
|
| 1998 | +-- We leave it up to the caller to decide how to handle the ambiguity.
|
|
| 1999 | +-- For example, GHCi may prompt the user to clarify which 'Module' is the correct one.
|
|
| 2000 | +--
|
|
| 2001 | +lookupLoadedHomeModuleByModuleName :: GhcMonad m => ModuleName -> m (Maybe [Module])
|
|
| 2002 | +lookupLoadedHomeModuleByModuleName mod_name = withSession $ \hsc_env -> liftIO $ do
|
|
| 2003 | + trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModuleByModuleName" <+> ppr mod_name)
|
|
| 2004 | + HUG.lookupAllHug (hsc_HUG hsc_env) mod_name >>= \case
|
|
| 2005 | + [] -> return Nothing
|
|
| 2006 | + mod_infos -> return (Just (mi_module . hm_iface <$> mod_infos))
|
|
| 2007 | + |
|
| 2008 | +-- | Given a 'ModuleName' and 'PkgQual', lookup all 'Module's that may fit the criteria.
|
|
| 2009 | +--
|
|
| 2010 | +-- Identically to 'lookupLoadedHomeModuleByModuleName', there may be more than one
|
|
| 2011 | +-- 'Module' in the 'HomeUnitGraph' that has the given 'ModuleName'.
|
|
| 2012 | +--
|
|
| 2013 | +-- The result is guaranteed to be non-empty, if no 'Module' can be found,
|
|
| 2014 | +-- this function throws an error.
|
|
| 2015 | +lookupAllQualifiedModuleNames :: GhcMonad m => PkgQual -> ModuleName -> m [Module]
|
|
| 2016 | +lookupAllQualifiedModuleNames NoPkgQual mod_name = withSession $ \hsc_env -> do
|
|
| 2017 | + home <- lookupLoadedHomeModuleByModuleName mod_name
|
|
| 2018 | + case home of
|
|
| 2019 | + Just m -> return m
|
|
| 2020 | + Nothing -> liftIO $ do
|
|
| 2021 | + let fc = hsc_FC hsc_env
|
|
| 2022 | + let units = hsc_units hsc_env
|
|
| 2023 | + let dflags = hsc_dflags hsc_env
|
|
| 2024 | + let fopts = initFinderOpts dflags
|
|
| 2025 | + res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
|
|
| 2026 | + case res of
|
|
| 2027 | + Found _ m -> return [m]
|
|
| 2028 | + err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
|
|
| 2029 | +lookupAllQualifiedModuleNames pkgqual mod_name = do
|
|
| 2030 | + m <- findQualifiedModule pkgqual mod_name
|
|
| 2031 | + pure [m]
|
|
| 2032 | + |
|
| 1829 | 2033 | -- | Check that a module is safe to import (according to Safe Haskell).
|
| 1830 | 2034 | --
|
| 1831 | 2035 | -- We return True to indicate the import is safe and False otherwise
|
| ... | ... | @@ -281,7 +281,7 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do |
| 281 | 281 | -- A simple edge to a module from the same home unit
|
| 282 | 282 | mkEdge (IIModule n) =
|
| 283 | 283 | let unitId = homeUnitId $ hsc_home_unit hsc_env
|
| 284 | - in (unitId, NormalLevel, NoPkgQual, GWIB (noLoc n) NotBoot)
|
|
| 284 | + in (unitId, NormalLevel, NoPkgQual, GWIB (noLoc $ moduleName n) NotBoot)
|
|
| 285 | 285 | -- A complete import statement
|
| 286 | 286 | mkEdge (IIDecl i) =
|
| 287 | 287 | let lvl = convImportLevel (ideclLevelSpec i)
|
| ... | ... | @@ -162,6 +162,7 @@ module GHC.Driver.Session ( |
| 162 | 162 | updOptLevel,
|
| 163 | 163 | setTmpDir,
|
| 164 | 164 | setUnitId,
|
| 165 | + setHomeUnitId,
|
|
| 165 | 166 | |
| 166 | 167 | TurnOnFlag,
|
| 167 | 168 | turnOn,
|
| ... | ... | @@ -3114,6 +3115,9 @@ parseUnitArg = |
| 3114 | 3115 | setUnitId :: String -> DynFlags -> DynFlags
|
| 3115 | 3116 | setUnitId p d = d { homeUnitId_ = stringToUnitId p }
|
| 3116 | 3117 | |
| 3118 | +setHomeUnitId :: UnitId -> DynFlags -> DynFlags
|
|
| 3119 | +setHomeUnitId p d = d { homeUnitId_ = p }
|
|
| 3120 | + |
|
| 3117 | 3121 | setWorkingDirectory :: String -> DynFlags -> DynFlags
|
| 3118 | 3122 | setWorkingDirectory p d = d { workingDirectory = Just p }
|
| 3119 | 3123 |
| ... | ... | @@ -918,12 +918,10 @@ findAndReadIface hsc_env doc_str mod wanted_mod hi_boot_file = do |
| 918 | 918 | case mb_found of
|
| 919 | 919 | InstalledFound loc -> do
|
| 920 | 920 | -- See Note [Home module load error]
|
| 921 | - case mhome_unit of
|
|
| 922 | - Just home_unit
|
|
| 923 | - | isHomeInstalledModule home_unit mod
|
|
| 924 | - , not (isOneShot (ghcMode dflags))
|
|
| 925 | - -> return (Failed (HomeModError mod loc))
|
|
| 926 | - _ -> do
|
|
| 921 | + if HUG.memberHugUnitId (moduleUnit mod) (hsc_HUG hsc_env)
|
|
| 922 | + && not (isOneShot (ghcMode dflags))
|
|
| 923 | + then return (Failed (HomeModError mod loc))
|
|
| 924 | + else do
|
|
| 927 | 925 | r <- read_file logger name_cache unit_state dflags wanted_mod (ml_hi_file loc)
|
| 928 | 926 | case r of
|
| 929 | 927 | Failed err
|
| ... | ... | @@ -364,7 +364,7 @@ importSuggestions looking_for ic currMod imports rdr_name |
| 364 | 364 | pick_interactive :: InteractiveImport -> Bool
|
| 365 | 365 | pick_interactive (IIDecl d) | mod_name == Just (unLoc (ideclName d)) = True
|
| 366 | 366 | | mod_name == fmap unLoc (ideclAs d) = True
|
| 367 | - pick_interactive (IIModule m) | mod_name == Just m = True
|
|
| 367 | + pick_interactive (IIModule m) | mod_name == Just (moduleName m) = True
|
|
| 368 | 368 | pick_interactive _ = False
|
| 369 | 369 | |
| 370 | 370 | -- We want to keep only one for each original module; preferably one with an
|
| ... | ... | @@ -115,6 +115,51 @@ The details are a bit tricky though: |
| 115 | 115 | modules.
|
| 116 | 116 | |
| 117 | 117 | |
| 118 | +Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId']
|
|
| 119 | +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
| 120 | +The 'InteractiveContext' is used to store 'DynFlags', 'Plugins' and similar
|
|
| 121 | +information about the so-called interactive "home unit". We are using
|
|
| 122 | +quotes here, since, originally, GHC wasn't aware of more than one 'HomeUnitEnv's.
|
|
| 123 | +So the 'InteractiveContext' was a hack/solution to have 'DynFlags' and 'Plugins'
|
|
| 124 | +independent of the 'DynFlags' and 'Plugins' stored in 'HscEnv'.
|
|
| 125 | +Nowadays, GHC has support for multiple home units via the 'HomeUnitGraph', thus,
|
|
| 126 | +this part of the 'InteractiveContext' is strictly speaking redundant, as we
|
|
| 127 | +can simply manage one 'HomeUnitEnv' for the 'DynFlags' and 'Plugins' that are
|
|
| 128 | +currently stored in the 'InteractiveContext'.
|
|
| 129 | + |
|
| 130 | +As a matter of fact, that's exactly what we do nowadays.
|
|
| 131 | +That means, we can also lift other restrictions in the future, for example
|
|
| 132 | +allowing @:seti@ commands to modify the package-flags, since we now have a
|
|
| 133 | +separate 'UnitState' for the interactive session.
|
|
| 134 | +However, we did not rip out 'ic_dflags' and 'ic_plugins', yet, as it makes
|
|
| 135 | +it easier to access them for functions that want to use the interactive 'DynFlags',
|
|
| 136 | +such as 'runInteractiveHsc' and 'mkInteractiveHscEnv', without having to look that
|
|
| 137 | +information up in the 'HomeUnitGraph'.
|
|
| 138 | +It is reasonable to change this in the future, and remove 'ic_dflags' and 'ic_plugins'.
|
|
| 139 | + |
|
| 140 | +We keep 'ic_dflags' and 'ic_plugins' around, but we also store a 'HomeUnitEnv'
|
|
| 141 | +for the 'DynFlags' and 'Plugins' of the interactive session.
|
|
| 142 | + |
|
| 143 | +It is important to keep the 'DynFlags' in these two places consistent.
|
|
| 144 | + |
|
| 145 | +In other words, whenever you update the 'DynFlags' of the 'interactiveGhciUnitId'
|
|
| 146 | +in the 'HscEnv', then you also need to update the 'DynFlags' of the
|
|
| 147 | +'InteractiveContext'.
|
|
| 148 | +The easiest way to update them is via 'setInteractiveDynFlags'.
|
|
| 149 | +However, careful, footgun! It is very easy to call 'setInteractiveDynFlags'
|
|
| 150 | +and forget to call 'normaliseInteractiveDynFlags' on the 'DynFlags' in the
|
|
| 151 | +'HscEnv'! This is important, because you may, accidentally, have enabled
|
|
| 152 | +Language Extensions that are not supported in the interactive ghc session,
|
|
| 153 | +which we do not want.
|
|
| 154 | + |
|
| 155 | +To summarise, the 'ic_dflags' and 'ic_plugins' are currently used to
|
|
| 156 | +conveniently cache them for easy access.
|
|
| 157 | +The 'ic_dflags' must be identical to the 'DynFlags' stored in the 'HscEnv'
|
|
| 158 | +for the 'HomeUnitEnv' identified by 'interactiveGhciUnitId'.
|
|
| 159 | + |
|
| 160 | +See Note [Multiple Home Units aware GHCi] for the design and rationale for
|
|
| 161 | +the current 'interactiveGhciUnitId'.
|
|
| 162 | + |
|
| 118 | 163 | Note [Interactively-bound Ids in GHCi]
|
| 119 | 164 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
| 120 | 165 | The Ids bound by previous Stmts in GHCi are currently
|
| ... | ... | @@ -296,7 +341,7 @@ data InteractiveImport |
| 296 | 341 | -- ^ Bring the exports of a particular module
|
| 297 | 342 | -- (filtered by an import decl) into scope
|
| 298 | 343 | |
| 299 | - | IIModule ModuleName
|
|
| 344 | + | IIModule Module
|
|
| 300 | 345 | -- ^ Bring into scope the entire top-level envt of
|
| 301 | 346 | -- of this module, including the things imported
|
| 302 | 347 | -- into it.
|
| ... | ... | @@ -119,7 +119,6 @@ import GHC.Unit |
| 119 | 119 | import GHC.Unit.Module.Graph
|
| 120 | 120 | import GHC.Unit.Module.ModIface
|
| 121 | 121 | import GHC.Unit.Home.ModInfo
|
| 122 | -import GHC.Unit.Home.PackageTable
|
|
| 123 | 122 | |
| 124 | 123 | import GHC.Tc.Module ( runTcInteractive, tcRnTypeSkolemising, loadUnqualIfaces )
|
| 125 | 124 | import GHC.Tc.Solver (simplifyWantedsTcM)
|
| ... | ... | @@ -823,16 +822,17 @@ findGlobalRdrEnv hsc_env imports |
| 823 | 822 | idecls :: [LImportDecl GhcPs]
|
| 824 | 823 | idecls = [noLocA d | IIDecl d <- imports]
|
| 825 | 824 | |
| 826 | - imods :: [ModuleName]
|
|
| 825 | + imods :: [Module]
|
|
| 827 | 826 | imods = [m | IIModule m <- imports]
|
| 828 | 827 | |
| 829 | - mkEnv mod = mkTopLevEnv hsc_env mod >>= \case
|
|
| 830 | - Left err -> pure $ Left (mod, err)
|
|
| 831 | - Right env -> pure $ Right env
|
|
| 828 | + mkEnv mod = do
|
|
| 829 | + mkTopLevEnv hsc_env mod >>= \case
|
|
| 830 | + Left err -> pure $ Left (moduleName mod, err)
|
|
| 831 | + Right env -> pure $ Right env
|
|
| 832 | 832 | |
| 833 | -mkTopLevEnv :: HscEnv -> ModuleName -> IO (Either String GlobalRdrEnv)
|
|
| 833 | +mkTopLevEnv :: HscEnv -> Module -> IO (Either String GlobalRdrEnv)
|
|
| 834 | 834 | mkTopLevEnv hsc_env modl
|
| 835 | - = lookupHpt hpt modl >>= \case
|
|
| 835 | + = HUG.lookupHugByModule modl hug >>= \case
|
|
| 836 | 836 | Nothing -> pure $ Left "not a home module"
|
| 837 | 837 | Just details ->
|
| 838 | 838 | case mi_top_env (hm_iface details) of
|
| ... | ... | @@ -857,7 +857,7 @@ mkTopLevEnv hsc_env modl |
| 857 | 857 | let exports_env = mkGlobalRdrEnv $ gresFromAvails hsc_env Nothing (getDetOrdAvails exports)
|
| 858 | 858 | pure $ Right $ plusGlobalRdrEnv imports_env exports_env
|
| 859 | 859 | where
|
| 860 | - hpt = hsc_HPT hsc_env
|
|
| 860 | + hug = hsc_HUG hsc_env
|
|
| 861 | 861 | |
| 862 | 862 | -- | Get the interactive evaluation context, consisting of a pair of the
|
| 863 | 863 | -- set of modules from which we take the full top-level scope, and the set
|
| ... | ... | @@ -870,11 +870,9 @@ getContext = withSession $ \HscEnv{ hsc_IC=ic } -> |
| 870 | 870 | -- its full top-level scope available.
|
| 871 | 871 | moduleIsInterpreted :: GhcMonad m => Module -> m Bool
|
| 872 | 872 | moduleIsInterpreted modl = withSession $ \h ->
|
| 873 | - if notHomeModule (hsc_home_unit h) modl
|
|
| 874 | - then return False
|
|
| 875 | - else liftIO (HUG.lookupHugByModule modl (hsc_HUG h)) >>= \case
|
|
| 876 | - Just hmi -> return (isJust $ homeModInfoByteCode hmi)
|
|
| 877 | - _not_a_home_module -> return False
|
|
| 873 | + liftIO (HUG.lookupHugByModule modl (hsc_HUG h)) >>= \case
|
|
| 874 | + Just hmi -> return (isJust $ homeModInfoByteCode hmi)
|
|
| 875 | + _not_a_home_module -> return False
|
|
| 878 | 876 | |
| 879 | 877 | -- | Looks up an identifier in the current interactive context (for :info)
|
| 880 | 878 | -- Filter the instances by the ones whose tycons (or classes resp)
|
| ... | ... | @@ -78,7 +78,7 @@ import Control.Monad |
| 78 | 78 | import Data.Char
|
| 79 | 79 | |
| 80 | 80 | import GHC.Unit.Module
|
| 81 | -import GHC.Unit.Home.PackageTable (lookupHpt)
|
|
| 81 | +import qualified GHC.Unit.Home.Graph as HUG
|
|
| 82 | 82 | |
| 83 | 83 | import Data.Array
|
| 84 | 84 | import Data.Coerce (coerce)
|
| ... | ... | @@ -458,8 +458,7 @@ schemeER_wrk d p rhs = schemeE d 0 p rhs |
| 458 | 458 | -- If that is 'Nothing', consider breakpoints to be disabled and skip the
|
| 459 | 459 | -- instruction.
|
| 460 | 460 | --
|
| 461 | --- If the breakpoint is inlined from another module, look it up in the home
|
|
| 462 | --- package table.
|
|
| 461 | +-- If the breakpoint is inlined from another module, look it up in the HUG (home unit graph).
|
|
| 463 | 462 | -- If the module doesn't exist there, or its module pointer is null (which means
|
| 464 | 463 | -- that the 'ModBreaks' value is uninitialized), skip the instruction.
|
| 465 | 464 | break_info ::
|
| ... | ... | @@ -472,7 +471,7 @@ break_info hsc_env mod current_mod current_mod_breaks |
| 472 | 471 | | mod == current_mod
|
| 473 | 472 | = pure $ check_mod_ptr =<< current_mod_breaks
|
| 474 | 473 | | otherwise
|
| 475 | - = ioToBc (lookupHpt (hsc_HPT hsc_env) (moduleName mod)) >>= \case
|
|
| 474 | + = ioToBc (HUG.lookupHugByModule mod (hsc_HUG hsc_env)) >>= \case
|
|
| 476 | 475 | Just hp -> pure $ check_mod_ptr (getModBreaks hp)
|
| 477 | 476 | Nothing -> pure Nothing
|
| 478 | 477 | where
|
| ... | ... | @@ -461,7 +461,7 @@ computeLinkDependencies cfg unit_env link_spec finder_opts finder_cache ar_cache |
| 461 | 461 | |
| 462 | 462 | -- all the units we want to link together, without their dependencies
|
| 463 | 463 | let root_units = filter (/= ue_currentUnit unit_env)
|
| 464 | - $ filter (/= interactiveUnitId)
|
|
| 464 | + $ filter (/= interactiveUnitId) -- TODO @fendor: what does this do?
|
|
| 465 | 465 | $ nub
|
| 466 | 466 | $ rts_wired_units ++ reverse obj_units ++ reverse units
|
| 467 | 467 |
| ... | ... | @@ -150,7 +150,6 @@ import GHC.Types.Basic hiding( SuccessFlag(..) ) |
| 150 | 150 | import GHC.Types.Annotations
|
| 151 | 151 | import GHC.Types.SrcLoc
|
| 152 | 152 | import GHC.Types.SourceFile
|
| 153 | -import GHC.Types.PkgQual
|
|
| 154 | 153 | import qualified GHC.LanguageExtensions as LangExt
|
| 155 | 154 | |
| 156 | 155 | import GHC.Unit.Env as UnitEnv
|
| ... | ... | @@ -2119,15 +2118,18 @@ runTcInteractive hsc_env thing_inside |
| 2119 | 2118 | , let local_gres = filter isLocalGRE gres
|
| 2120 | 2119 | , not (null local_gres) ]) ]
|
| 2121 | 2120 | |
| 2122 | - ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface
|
|
| 2123 | - : dep_orphs (mi_deps iface))
|
|
| 2124 | - (loadSrcInterface (text "runTcInteractive") m
|
|
| 2125 | - NotBoot mb_pkg)
|
|
| 2121 | + ; let getOrphansForModuleName m mb_pkg = do
|
|
| 2122 | + iface <- loadSrcInterface (text "runTcInteractive") m NotBoot mb_pkg
|
|
| 2123 | + pure $ mi_module iface : dep_orphs (mi_deps iface)
|
|
| 2124 | + |
|
| 2125 | + getOrphansForModule m = do
|
|
| 2126 | + iface <- loadModuleInterface (text "runTcInteractive") m
|
|
| 2127 | + pure $ mi_module iface : dep_orphs (mi_deps iface)
|
|
| 2126 | 2128 | |
| 2127 | 2129 | ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
|
| 2128 | 2130 | case i of -- force above: see #15111
|
| 2129 | - IIModule n -> getOrphans n NoPkgQual
|
|
| 2130 | - IIDecl i -> getOrphans (unLoc (ideclName i))
|
|
| 2131 | + IIModule n -> getOrphansForModule n
|
|
| 2132 | + IIDecl i -> getOrphansForModuleName (unLoc (ideclName i))
|
|
| 2131 | 2133 | (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i))
|
| 2132 | 2134 | |
| 2133 | 2135 |
| ... | ... | @@ -13,6 +13,7 @@ import GHC.Data.FastString |
| 13 | 13 | |
| 14 | 14 | import GHC.Unit
|
| 15 | 15 | import GHC.Unit.Env
|
| 16 | +import qualified GHC.Unit.Home.Graph as HUG
|
|
| 16 | 17 | |
| 17 | 18 | import GHC.Types.Name
|
| 18 | 19 | import GHC.Types.Name.Reader
|
| ... | ... | @@ -72,12 +73,11 @@ mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrE |
| 72 | 73 | mkNamePprCtx ptc unit_env env
|
| 73 | 74 | = QueryQualify
|
| 74 | 75 | (mkQualName env)
|
| 75 | - (mkQualModule unit_state home_unit)
|
|
| 76 | + (mkQualModule unit_state unit_env)
|
|
| 76 | 77 | (mkQualPackage unit_state)
|
| 77 | 78 | (mkPromTick ptc env)
|
| 78 | 79 | where
|
| 79 | 80 | unit_state = ue_homeUnitState unit_env
|
| 80 | - home_unit = ue_homeUnit unit_env
|
|
| 81 | 81 | |
| 82 | 82 | mkQualName :: Outputable info => GlobalRdrEnvX info -> QueryQualifyName
|
| 83 | 83 | mkQualName env = qual_name where
|
| ... | ... | @@ -215,10 +215,12 @@ Side note (int-index): |
| 215 | 215 | -- | Creates a function for formatting modules based on two heuristics:
|
| 216 | 216 | -- (1) if the module is the current module, don't qualify, and (2) if there
|
| 217 | 217 | -- is only one exposed package which exports this module, don't qualify.
|
| 218 | -mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
|
|
| 219 | -mkQualModule unit_state mhome_unit mod
|
|
| 220 | - | Just home_unit <- mhome_unit
|
|
| 221 | - , isHomeModule home_unit mod = False
|
|
| 218 | +mkQualModule :: UnitState -> UnitEnv -> QueryQualifyModule
|
|
| 219 | +mkQualModule unit_state unitEnv mod
|
|
| 220 | + -- Check whether the unit of the module is in the HomeUnitGraph.
|
|
| 221 | + -- If it is, then we consider this 'mod' to be "local" and don't
|
|
| 222 | + -- want to qualify it.
|
|
| 223 | + | HUG.memberHugUnit (moduleUnit mod) (ue_home_unit_graph unitEnv) = False
|
|
| 222 | 224 | |
| 223 | 225 | | [(_, pkgconfig)] <- lookup,
|
| 224 | 226 | mkUnit pkgconfig == moduleUnit mod
|
| ... | ... | @@ -241,7 +241,7 @@ isUnitEnvInstalledModule ue m = maybe False (`isHomeInstalledModule` m) hu |
| 241 | 241 | -- -------------------------------------------------------
|
| 242 | 242 | |
| 243 | 243 | ue_findHomeUnitEnv :: HasDebugCallStack => UnitId -> UnitEnv -> HomeUnitEnv
|
| 244 | -ue_findHomeUnitEnv uid e = case HUG.lookupHugUnit uid (ue_home_unit_graph e) of
|
|
| 244 | +ue_findHomeUnitEnv uid e = case HUG.lookupHugUnitId uid (ue_home_unit_graph e) of
|
|
| 245 | 245 | Nothing -> pprPanic "Unit unknown to the internal unit environment"
|
| 246 | 246 | $ text "unit (" <> ppr uid <> text ")"
|
| 247 | 247 | $$ ppr (HUG.allUnits (ue_home_unit_graph e))
|
| ... | ... | @@ -311,7 +311,7 @@ ue_unitHomeUnit uid = expectJust . ue_unitHomeUnit_maybe uid |
| 311 | 311 | |
| 312 | 312 | ue_unitHomeUnit_maybe :: UnitId -> UnitEnv -> Maybe HomeUnit
|
| 313 | 313 | ue_unitHomeUnit_maybe uid ue_env =
|
| 314 | - HUG.homeUnitEnv_home_unit =<< HUG.lookupHugUnit uid (ue_home_unit_graph ue_env)
|
|
| 314 | + HUG.homeUnitEnv_home_unit =<< HUG.lookupHugUnitId uid (ue_home_unit_graph ue_env)
|
|
| 315 | 315 | |
| 316 | 316 | -- -------------------------------------------------------
|
| 317 | 317 | -- Query and modify the currently active unit
|
| ... | ... | @@ -319,7 +319,7 @@ ue_unitHomeUnit_maybe uid ue_env = |
| 319 | 319 | |
| 320 | 320 | ue_currentHomeUnitEnv :: HasDebugCallStack => UnitEnv -> HomeUnitEnv
|
| 321 | 321 | ue_currentHomeUnitEnv e =
|
| 322 | - case HUG.lookupHugUnit (ue_currentUnit e) (ue_home_unit_graph e) of
|
|
| 322 | + case HUG.lookupHugUnitId (ue_currentUnit e) (ue_home_unit_graph e) of
|
|
| 323 | 323 | Just unitEnv -> unitEnv
|
| 324 | 324 | Nothing -> pprPanic "packageNotFound" $
|
| 325 | 325 | (ppr $ ue_currentUnit e) $$ ppr (HUG.allUnits (ue_home_unit_graph e))
|
| ... | ... | @@ -389,7 +389,7 @@ ue_transitiveHomeDeps uid e = |
| 389 | 389 | -- FIXME: Shouldn't this be a proper assertion only used in debug mode?
|
| 390 | 390 | assertUnitEnvInvariant :: HasDebugCallStack => UnitEnv -> UnitEnv
|
| 391 | 391 | assertUnitEnvInvariant u =
|
| 392 | - case HUG.lookupHugUnit (ue_current_unit u) (ue_home_unit_graph u) of
|
|
| 392 | + case HUG.lookupHugUnitId (ue_current_unit u) (ue_home_unit_graph u) of
|
|
| 393 | 393 | Just _ -> u
|
| 394 | 394 | Nothing ->
|
| 395 | 395 | pprPanic "invariant" (ppr (ue_current_unit u) $$ ppr (HUG.allUnits (ue_home_unit_graph u)))
|
| ... | ... | @@ -34,7 +34,10 @@ module GHC.Unit.Home.Graph |
| 34 | 34 | , lookupHug
|
| 35 | 35 | , lookupHugByModule
|
| 36 | 36 | , lookupHugUnit
|
| 37 | - |
|
| 37 | + , lookupHugUnitId
|
|
| 38 | + , lookupAllHug
|
|
| 39 | + , memberHugUnit
|
|
| 40 | + , memberHugUnitId
|
|
| 38 | 41 | -- ** Reachability
|
| 39 | 42 | , transitiveHomeDeps
|
| 40 | 43 | |
| ... | ... | @@ -62,6 +65,8 @@ module GHC.Unit.Home.Graph |
| 62 | 65 | , unitEnv_insert
|
| 63 | 66 | , unitEnv_new
|
| 64 | 67 | , unitEnv_lookup
|
| 68 | + , unitEnv_traverseWithKey
|
|
| 69 | + , unitEnv_assocs
|
|
| 65 | 70 | ) where
|
| 66 | 71 | |
| 67 | 72 | import GHC.Prelude
|
| ... | ... | @@ -73,6 +78,7 @@ import GHC.Unit.Home.PackageTable |
| 73 | 78 | import GHC.Unit.Module
|
| 74 | 79 | import GHC.Unit.Module.ModIface
|
| 75 | 80 | import GHC.Unit.State
|
| 81 | +import GHC.Utils.Monad (mapMaybeM)
|
|
| 76 | 82 | import GHC.Utils.Outputable
|
| 77 | 83 | import GHC.Utils.Panic
|
| 78 | 84 | |
| ... | ... | @@ -222,7 +228,7 @@ updateUnitFlags uid f = unitEnv_adjust update uid |
| 222 | 228 | -- | Compute the transitive closure of a unit in the 'HomeUnitGraph'.
|
| 223 | 229 | -- If the argument unit is not present in the graph returns Nothing.
|
| 224 | 230 | transitiveHomeDeps :: UnitId -> HomeUnitGraph -> Maybe [UnitId]
|
| 225 | -transitiveHomeDeps uid hug = case lookupHugUnit uid hug of
|
|
| 231 | +transitiveHomeDeps uid hug = case lookupHugUnitId uid hug of
|
|
| 226 | 232 | Nothing -> Nothing
|
| 227 | 233 | Just hue -> Just $
|
| 228 | 234 | Set.toList (loop (Set.singleton uid) (homeUnitDepends (homeUnitEnv_units hue)))
|
| ... | ... | @@ -234,7 +240,7 @@ transitiveHomeDeps uid hug = case lookupHugUnit uid hug of |
| 234 | 240 | let hue = homeUnitDepends
|
| 235 | 241 | . homeUnitEnv_units
|
| 236 | 242 | . expectJust
|
| 237 | - $ lookupHugUnit uid hug
|
|
| 243 | + $ lookupHugUnitId uid hug
|
|
| 238 | 244 | in loop (Set.insert uid acc) (hue ++ uids)
|
| 239 | 245 | |
| 240 | 246 | --------------------------------------------------------------------------------
|
| ... | ... | @@ -246,21 +252,47 @@ transitiveHomeDeps uid hug = case lookupHugUnit uid hug of |
| 246 | 252 | lookupHug :: HomeUnitGraph -> UnitId -> ModuleName -> IO (Maybe HomeModInfo)
|
| 247 | 253 | lookupHug hug uid mod = do
|
| 248 | 254 | case unitEnv_lookup_maybe uid hug of
|
| 249 | - -- Really, here we want "lookup HPT" rather than unitEnvLookup
|
|
| 250 | 255 | Nothing -> pure Nothing
|
| 251 | 256 | Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod
|
| 252 | 257 | |
| 253 | 258 | -- | Lookup the 'HomeModInfo' of a 'Module' in the 'HomeUnitGraph' (via the 'HomePackageTable' of the corresponding unit)
|
| 254 | 259 | lookupHugByModule :: Module -> HomeUnitGraph -> IO (Maybe HomeModInfo)
|
| 255 | -lookupHugByModule mod hug
|
|
| 256 | - | otherwise = do
|
|
| 257 | - case unitEnv_lookup_maybe (toUnitId $ moduleUnit mod) hug of
|
|
| 258 | - Nothing -> pure Nothing
|
|
| 259 | - Just env -> lookupHptByModule (homeUnitEnv_hpt env) mod
|
|
| 260 | +lookupHugByModule mod hug =
|
|
| 261 | + case lookupHugUnit (moduleUnit mod) hug of
|
|
| 262 | + Nothing -> pure Nothing
|
|
| 263 | + Just env -> lookupHptByModule (homeUnitEnv_hpt env) mod
|
|
| 264 | + |
|
| 265 | +-- | Lookup all 'HomeModInfo' that have the same 'ModuleName' as the given 'ModuleName'.
|
|
| 266 | +-- 'ModuleName's are not unique in the case of multiple home units, so there can be
|
|
| 267 | +-- more than one possible 'HomeModInfo'.
|
|
| 268 | +--
|
|
| 269 | +-- You should always prefer 'lookupHug' and 'lookupHugByModule' when possible.
|
|
| 270 | +lookupAllHug :: HomeUnitGraph -> ModuleName -> IO [HomeModInfo]
|
|
| 271 | +lookupAllHug hug mod = mapMaybeM (\uid -> lookupHug hug uid mod) (Set.toList $ unitEnv_keys hug)
|
|
| 260 | 272 | |
| 261 | 273 | -- | Lookup a 'HomeUnitEnv' by 'UnitId' in a 'HomeUnitGraph'
|
| 262 | -lookupHugUnit :: UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv
|
|
| 263 | -lookupHugUnit = unitEnv_lookup_maybe
|
|
| 274 | +lookupHugUnitId :: UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv
|
|
| 275 | +lookupHugUnitId = unitEnv_lookup_maybe
|
|
| 276 | + |
|
| 277 | +-- | Check whether the 'UnitId' is present in the 'HomeUnitGraph'
|
|
| 278 | +memberHugUnitId :: UnitId -> HomeUnitGraph -> Bool
|
|
| 279 | +memberHugUnitId u = isJust . lookupHugUnitId u
|
|
| 280 | + |
|
| 281 | +-- | Lookup up the 'HomeUnitEnv' by the 'Unit' in the 'HomeUnitGraph'.
|
|
| 282 | +-- If the 'Unit' can be turned into a 'UnitId', we behave identical to 'lookupHugUnitId'.
|
|
| 283 | +--
|
|
| 284 | +-- A 'HoleUnit' is never part of the 'HomeUnitGraph', only instantiated 'Unit's
|
|
| 285 | +lookupHugUnit :: Unit -> HomeUnitGraph -> Maybe HomeUnitEnv
|
|
| 286 | +lookupHugUnit unit hug =
|
|
| 287 | + if isHoleUnit unit
|
|
| 288 | + then Nothing
|
|
| 289 | + else lookupHugUnitId (toUnitId unit) hug
|
|
| 290 | + |
|
| 291 | +-- | Check whether the 'Unit' is present in the 'HomeUnitGraph'
|
|
| 292 | +--
|
|
| 293 | +-- A 'HoleUnit' is never part of the 'HomeUnitGraph', only instantiated 'Unit's
|
|
| 294 | +memberHugUnit :: Unit -> HomeUnitGraph -> Bool
|
|
| 295 | +memberHugUnit u = isJust . lookupHugUnit u
|
|
| 264 | 296 | |
| 265 | 297 | --------------------------------------------------------------------------------
|
| 266 | 298 | -- * Internal representation map
|
| ... | ... | @@ -313,6 +345,13 @@ unitEnv_foldWithKey f z (UnitEnvGraph g)= Map.foldlWithKey' f z g |
| 313 | 345 | unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v
|
| 314 | 346 | unitEnv_lookup u env = expectJust $ unitEnv_lookup_maybe u env
|
| 315 | 347 | |
| 348 | +unitEnv_traverseWithKey :: Applicative f => (UnitEnvGraphKey -> a -> f b) -> UnitEnvGraph a -> f (UnitEnvGraph b)
|
|
| 349 | +unitEnv_traverseWithKey f unitEnv =
|
|
| 350 | + UnitEnvGraph <$> Map.traverseWithKey f (unitEnv_graph unitEnv)
|
|
| 351 | + |
|
| 352 | +unitEnv_assocs :: UnitEnvGraph a -> [(UnitEnvGraphKey, a)]
|
|
| 353 | +unitEnv_assocs (UnitEnvGraph x) = Map.assocs x
|
|
| 354 | + |
|
| 316 | 355 | --------------------------------------------------------------------------------
|
| 317 | 356 | -- * Utilities
|
| 318 | 357 | --------------------------------------------------------------------------------
|
| ... | ... | @@ -63,12 +63,16 @@ module GHC.Unit.Types |
| 63 | 63 | , mainUnitId
|
| 64 | 64 | , thisGhcUnitId
|
| 65 | 65 | , interactiveUnitId
|
| 66 | + , interactiveGhciUnitId
|
|
| 67 | + , interactiveSessionUnitId
|
|
| 66 | 68 | |
| 67 | 69 | , ghcInternalUnit
|
| 68 | 70 | , rtsUnit
|
| 69 | 71 | , mainUnit
|
| 70 | 72 | , thisGhcUnit
|
| 71 | 73 | , interactiveUnit
|
| 74 | + , interactiveGhciUnit
|
|
| 75 | + , interactiveSessionUnit
|
|
| 72 | 76 | |
| 73 | 77 | , isInteractiveModule
|
| 74 | 78 | , wiredInUnitIds
|
| ... | ... | @@ -588,20 +592,24 @@ Make sure you change 'GHC.Unit.State.findWiredInUnits' if you add an entry here. |
| 588 | 592 | -}
|
| 589 | 593 | |
| 590 | 594 | ghcInternalUnitId, rtsUnitId,
|
| 591 | - mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId
|
|
| 595 | + mainUnitId, thisGhcUnitId, interactiveUnitId, interactiveGhciUnitId, interactiveSessionUnitId :: UnitId
|
|
| 592 | 596 | |
| 593 | 597 | ghcInternalUnit, rtsUnit,
|
| 594 | - mainUnit, thisGhcUnit, interactiveUnit :: Unit
|
|
| 598 | + mainUnit, thisGhcUnit, interactiveUnit, interactiveGhciUnit, interactiveSessionUnit :: Unit
|
|
| 595 | 599 | |
| 596 | 600 | ghcInternalUnitId = UnitId (fsLit "ghc-internal")
|
| 597 | 601 | rtsUnitId = UnitId (fsLit "rts")
|
| 598 | 602 | thisGhcUnitId = UnitId (fsLit cProjectUnitId) -- See Note [GHC's Unit Id]
|
| 599 | 603 | interactiveUnitId = UnitId (fsLit "interactive")
|
| 604 | +interactiveGhciUnitId = UnitId (fsLit "interactive-ghci")
|
|
| 605 | +interactiveSessionUnitId = UnitId (fsLit "interactive-session")
|
|
| 600 | 606 | |
| 601 | 607 | ghcInternalUnit = RealUnit (Definite ghcInternalUnitId)
|
| 602 | 608 | rtsUnit = RealUnit (Definite rtsUnitId)
|
| 603 | 609 | thisGhcUnit = RealUnit (Definite thisGhcUnitId)
|
| 604 | 610 | interactiveUnit = RealUnit (Definite interactiveUnitId)
|
| 611 | +interactiveGhciUnit = RealUnit (Definite interactiveGhciUnitId)
|
|
| 612 | +interactiveSessionUnit = RealUnit (Definite interactiveSessionUnitId)
|
|
| 605 | 613 | |
| 606 | 614 | -- | This is the package Id for the current program. It is the default
|
| 607 | 615 | -- package Id if you don't specify a package name. We don't add this prefix
|
| ... | ... | @@ -113,6 +113,7 @@ import GHC.Utils.Misc |
| 113 | 113 | import qualified GHC.LanguageExtensions as LangExt
|
| 114 | 114 | import qualified GHC.Data.Strict as Strict
|
| 115 | 115 | import GHC.Types.Error
|
| 116 | +import qualified GHC.Unit.Home.Graph as HUG
|
|
| 116 | 117 | |
| 117 | 118 | -- Haskell Libraries
|
| 118 | 119 | import System.Console.Haskeline as Haskeline
|
| ... | ... | @@ -129,6 +130,7 @@ import Data.Array |
| 129 | 130 | import qualified Data.ByteString.Char8 as BS
|
| 130 | 131 | import Data.Char
|
| 131 | 132 | import Data.Function
|
| 133 | +import qualified Data.Foldable as Foldable
|
|
| 132 | 134 | import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
|
| 133 | 135 | import Data.List ( find, intercalate, intersperse,
|
| 134 | 136 | isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )
|
| ... | ... | @@ -204,31 +206,31 @@ ghciCommands = map mkCmd [ |
| 204 | 206 | -- Hugs users are accustomed to :e, so make sure it doesn't overlap
|
| 205 | 207 | ("?", keepGoing help, noCompletion),
|
| 206 | 208 | ("add", keepGoingPaths addModule, completeFilename),
|
| 207 | - ("abandon", keepGoing abandonCmd, noCompletion),
|
|
| 208 | - ("break", keepGoing breakCmd, completeBreakpoint),
|
|
| 209 | - ("back", keepGoing backCmd, noCompletion),
|
|
| 209 | + ("abandon", keepGoing abandonCmd, noCompletion),
|
|
| 210 | + ("break", keepGoing breakCmd, completeBreakpoint),
|
|
| 211 | + ("back", keepGoing backCmd, noCompletion),
|
|
| 210 | 212 | ("browse", keepGoing' (browseCmd False), completeModule),
|
| 211 | 213 | ("browse!", keepGoing' (browseCmd True), completeModule),
|
| 212 | - ("cd", keepGoingMulti' changeDirectory, completeFilename),
|
|
| 213 | - ("continue", keepGoing continueCmd, noCompletion),
|
|
| 214 | + ("cd", keepGoing' changeDirectory, completeFilename),
|
|
| 215 | + ("continue", keepGoing' continueCmd, noCompletion),
|
|
| 214 | 216 | ("cmd", keepGoing cmdCmd, completeExpression),
|
| 215 | 217 | ("def", keepGoing (defineMacro False), completeExpression),
|
| 216 | 218 | ("def!", keepGoing (defineMacro True), completeExpression),
|
| 217 | 219 | ("delete", keepGoing deleteCmd, noCompletion),
|
| 218 | 220 | ("disable", keepGoing disableCmd, noCompletion),
|
| 219 | 221 | ("doc", keepGoing' docCmd, completeIdentifier),
|
| 220 | - ("edit", keepGoingMulti' editFile, completeFilename),
|
|
| 222 | + ("edit", keepGoing' editFile, completeFilename),
|
|
| 221 | 223 | ("enable", keepGoing enableCmd, noCompletion),
|
| 222 | 224 | ("force", keepGoing forceCmd, completeExpression),
|
| 223 | 225 | ("forward", keepGoing forwardCmd, noCompletion),
|
| 224 | - ("help", keepGoingMulti help, noCompletion),
|
|
| 225 | - ("history", keepGoingMulti historyCmd, noCompletion),
|
|
| 226 | - ("info", keepGoingMulti' (info False), completeIdentifier),
|
|
| 227 | - ("info!", keepGoingMulti' (info True), completeIdentifier),
|
|
| 226 | + ("help", keepGoing help, noCompletion),
|
|
| 227 | + ("history", keepGoing historyCmd, noCompletion),
|
|
| 228 | + ("info", keepGoing' (info False), completeIdentifier),
|
|
| 229 | + ("info!", keepGoing' (info True), completeIdentifier),
|
|
| 228 | 230 | ("issafe", keepGoing' isSafeCmd, completeModule),
|
| 229 | 231 | ("ignore", keepGoing ignoreCmd, noCompletion),
|
| 230 | - ("kind", keepGoingMulti' (kindOfType False), completeIdentifier),
|
|
| 231 | - ("kind!", keepGoingMulti' (kindOfType True), completeIdentifier),
|
|
| 232 | + ("kind", keepGoing' (kindOfType False), completeIdentifier),
|
|
| 233 | + ("kind!", keepGoing' (kindOfType True), completeIdentifier),
|
|
| 232 | 234 | ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
|
| 233 | 235 | ("load!", keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),
|
| 234 | 236 | ("list", keepGoing' listCmd, noCompletion),
|
| ... | ... | @@ -236,19 +238,19 @@ ghciCommands = map mkCmd [ |
| 236 | 238 | ("main", keepGoing runMain, completeFilename),
|
| 237 | 239 | ("print", keepGoing printCmd, completeExpression),
|
| 238 | 240 | ("quit", quit, noCompletion),
|
| 239 | - ("reload", keepGoingMulti' reloadModule, noCompletion),
|
|
| 240 | - ("reload!", keepGoingMulti' reloadModuleDefer, noCompletion),
|
|
| 241 | - ("run", keepGoing runRun, completeFilename),
|
|
| 241 | + ("reload", keepGoing' reloadModule, noCompletion),
|
|
| 242 | + ("reload!", keepGoing' reloadModuleDefer, noCompletion),
|
|
| 243 | + ("run", keepGoing' runRun, completeFilename),
|
|
| 242 | 244 | ("script", keepGoing' scriptCmd, completeFilename),
|
| 243 | - ("set", keepGoingMulti setCmd, completeSetOptions),
|
|
| 244 | - ("seti", keepGoingMulti setiCmd, completeSeti),
|
|
| 245 | - ("show", keepGoingMulti' showCmd, completeShowOptions),
|
|
| 246 | - ("showi", keepGoing showiCmd, completeShowiOptions),
|
|
| 245 | + ("set", keepGoing setCmd, completeSetOptions),
|
|
| 246 | + ("seti", keepGoing setiCmd, completeSeti),
|
|
| 247 | + ("show", keepGoing' showCmd, completeShowOptions),
|
|
| 248 | + ("showi", keepGoing showiCmd, completeShowiOptions),
|
|
| 247 | 249 | ("sprint", keepGoing sprintCmd, completeExpression),
|
| 248 | 250 | ("step", keepGoing stepCmd, completeIdentifier),
|
| 249 | 251 | ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
|
| 250 | 252 | ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
|
| 251 | - ("type", keepGoingMulti' typeOfExpr, completeExpression),
|
|
| 253 | + ("type", keepGoing' typeOfExpr, completeExpression),
|
|
| 252 | 254 | ("trace", keepGoing traceCmd, completeExpression),
|
| 253 | 255 | ("unadd", keepGoingPaths unAddModule, completeFilename),
|
| 254 | 256 | ("undef", keepGoing undefineMacro, completeMacro),
|
| ... | ... | @@ -316,24 +318,11 @@ showSDocForUserQualify doc = do |
| 316 | 318 | keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)
|
| 317 | 319 | keepGoing a str = keepGoing' (lift . a) str
|
| 318 | 320 | |
| 319 | -keepGoingMulti :: (String -> GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)
|
|
| 320 | -keepGoingMulti a str = keepGoingMulti' (lift . a) str
|
|
| 321 | - |
|
| 322 | 321 | keepGoing' :: GhciMonad m => (a -> m ()) -> a -> m CmdExecOutcome
|
| 323 | 322 | keepGoing' a str = do
|
| 324 | - in_multi <- inMultiMode
|
|
| 325 | - if in_multi
|
|
| 326 | - then reportError GhciCommandNotSupportedInMultiMode
|
|
| 327 | - else a str
|
|
| 323 | + a str
|
|
| 328 | 324 | return CmdSuccess
|
| 329 | 325 | |
| 330 | --- For commands which are actually support in multi-mode, initially just :reload
|
|
| 331 | -keepGoingMulti' :: GhciMonad m => (String -> m ()) -> String -> m CmdExecOutcome
|
|
| 332 | -keepGoingMulti' a str = a str >> return CmdSuccess
|
|
| 333 | - |
|
| 334 | -inMultiMode :: GhciMonad m => m Bool
|
|
| 335 | -inMultiMode = multiMode <$> getGHCiState
|
|
| 336 | - |
|
| 337 | 326 | keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi CmdExecOutcome)
|
| 338 | 327 | keepGoingPaths a str
|
| 339 | 328 | = do case toArgsNoLoc str of
|
| ... | ... | @@ -489,9 +478,6 @@ default_args = [] |
| 489 | 478 | interactiveUI :: GhciSettings -> [(FilePath, Maybe UnitId, Maybe Phase)] -> Maybe [String]
|
| 490 | 479 | -> Ghc ()
|
| 491 | 480 | interactiveUI config srcs maybe_exprs = do
|
| 492 | - -- This is a HACK to make sure dynflags are not overwritten when setting
|
|
| 493 | - -- options. When GHCi is made properly multi component it should be removed.
|
|
| 494 | - modifySession (\env -> hscSetActiveUnitId (hscActiveUnitId env) env)
|
|
| 495 | 481 | -- HACK! If we happen to get into an infinite loop (eg the user
|
| 496 | 482 | -- types 'let x=x in x' at the prompt), then the thread will block
|
| 497 | 483 | -- on a blackhole, and become unreachable during GC. The GC will
|
| ... | ... | @@ -507,21 +493,7 @@ interactiveUI config srcs maybe_exprs = do |
| 507 | 493 | -- Initialise buffering for the *interpreted* I/O system
|
| 508 | 494 | (nobuffering, flush) <- runInternal initInterpBuffering
|
| 509 | 495 | |
| 510 | - -- The initial set of DynFlags used for interactive evaluation is the same
|
|
| 511 | - -- as the global DynFlags, plus -XExtendedDefaultRules and
|
|
| 512 | - -- -XNoMonomorphismRestriction.
|
|
| 513 | - -- See Note [Changing language extensions for interactive evaluation] #10857
|
|
| 514 | - dflags <- getDynFlags
|
|
| 515 | - let dflags' = (xopt_set_unlessExplSpec
|
|
| 516 | - LangExt.ExtendedDefaultRules xopt_set)
|
|
| 517 | - . (xopt_set_unlessExplSpec
|
|
| 518 | - LangExt.MonomorphismRestriction xopt_unset)
|
|
| 519 | - $ dflags
|
|
| 520 | - GHC.setInteractiveDynFlags dflags'
|
|
| 521 | - _ <- GHC.setProgramDynFlags
|
|
| 522 | - -- Set Opt_KeepGoing so that :reload loads as much as
|
|
| 523 | - -- possible
|
|
| 524 | - (gopt_set dflags Opt_KeepGoing)
|
|
| 496 | + installInteractiveHomeUnit
|
|
| 525 | 497 | |
| 526 | 498 | -- Update the LogAction. Ensure we don't override the user's log action lest
|
| 527 | 499 | -- we break -ddump-json (#14078)
|
| ... | ... | @@ -553,9 +525,6 @@ interactiveUI config srcs maybe_exprs = do |
| 553 | 525 | case simpleImportDecl preludeModuleName of
|
| 554 | 526 | -- Set to True because Prelude is implicitly imported.
|
| 555 | 527 | impDecl@ImportDecl{ideclExt=ext} -> impDecl{ideclExt = ext{ideclImplicit=True}}
|
| 556 | - hsc_env <- GHC.getSession
|
|
| 557 | - let !in_multi = length (hsc_all_home_unit_ids hsc_env) > 1
|
|
| 558 | - -- We force this to make sure we don't retain the hsc_env when reloading
|
|
| 559 | 528 | empty_cache <- liftIO newIfaceCache
|
| 560 | 529 | startGHCi (runGHCi srcs maybe_exprs)
|
| 561 | 530 | GHCiState{ progname = default_progname,
|
| ... | ... | @@ -566,7 +535,6 @@ interactiveUI config srcs maybe_exprs = do |
| 566 | 535 | stop = default_stop,
|
| 567 | 536 | editor = default_editor,
|
| 568 | 537 | options = [],
|
| 569 | - multiMode = in_multi,
|
|
| 570 | 538 | localConfig = SourceLocalConfig,
|
| 571 | 539 | -- We initialize line number as 0, not 1, because we use
|
| 572 | 540 | -- current line number while reporting errors which is
|
| ... | ... | @@ -595,6 +563,243 @@ interactiveUI config srcs maybe_exprs = do |
| 595 | 563 | |
| 596 | 564 | return ()
|
| 597 | 565 | |
| 566 | +{-
|
|
| 567 | +Note [Multiple Home Units aware GHCi]
|
|
| 568 | +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
| 569 | +GHCi supported multiple home units up to a certain degree for quite a while now.
|
|
| 570 | +The supported feature set was limited, due to a design impasse:
|
|
| 571 | +One of the home units must be "active", e.g., there must be one 'HomeUnit'
|
|
| 572 | +whose 'UnitId' is "active" which is returned when calling
|
|
| 573 | + |
|
| 574 | +@'hscActiveUnitId' \<$\> 'getSession'@
|
|
| 575 | + |
|
| 576 | +This makes sense in a GHC session, since you are always compiling a particular
|
|
| 577 | +Module, but it makes less intuitive sense in an interactive session.
|
|
| 578 | +Given an expression to evaluate, we can't easily tell in which "context" the expression
|
|
| 579 | +should be parsed, typechecked and evaluated.
|
|
| 580 | +That's why initially, most of GHCi features, except for `:reload`ing were disabled
|
|
| 581 | +if the GHCi session had more than one 'HomeUnitEnv'.
|
|
| 582 | + |
|
| 583 | +We lift this restriction, enabling all features of GHCi for the multiple home unit case.
|
|
| 584 | +To do this, we fundamentally change the 'HomeUnitEnv' graph to be multiple home unit first.
|
|
| 585 | +Instead of differentiating the case were we have a single home unit and multiple,
|
|
| 586 | +we now always set up a multiple home unit session that scales seamlessly to an arbitrary
|
|
| 587 | +amount of home units.
|
|
| 588 | + |
|
| 589 | +We introduce two new 'HomeUnitEnv's that are always added to the 'HomeUnitGraph'.
|
|
| 590 | +They are:
|
|
| 591 | + |
|
| 592 | +The "interactive-ghci", called the 'interactiveGhciUnit', contains the same
|
|
| 593 | +'DynFlags' that are used by the 'InteractiveContext' for interactive evaluation
|
|
| 594 | +of expressions.
|
|
| 595 | +This 'HomeUnitEnv' is only used on the prompt of GHCi, so we may refer to it as
|
|
| 596 | +"interactive-prompt" unit.
|
|
| 597 | +See Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId']
|
|
| 598 | +for discussing its role.
|
|
| 599 | + |
|
| 600 | +And the 'interactive-session', called 'interactiveSessionUnit' or
|
|
| 601 | +'interactiveSessionUnitId', which is used for loading Scripts into
|
|
| 602 | +GHCi that are not 'Target's of any home unit, via `:load` or `:add`.
|
|
| 603 | + |
|
| 604 | +Both of these "interactive" home units depend on all other 'HomeUnitEnv's that
|
|
| 605 | +are passed as arguments on the cli.
|
|
| 606 | +Additionally, the "interactive-ghci" unit depends on 'interactive-session'.
|
|
| 607 | + |
|
| 608 | +We always evaluate expressions in the context of the
|
|
| 609 | +"interactive-ghci" session.
|
|
| 610 | +Since "interactive-ghci" depends on all home units, we can import any 'Module'
|
|
| 611 | +from the other home units with ease.
|
|
| 612 | + |
|
| 613 | +As we have a clear 'HomeUnitGraph' hierarchy, we can set 'interactiveGhciUnitId'
|
|
| 614 | +as the active home unit for the full duration of the GHCi session.
|
|
| 615 | +In GHCi, we always set 'interactiveGhciUnitId' to be the currently active home unit.
|
|
| 616 | + |
|
| 617 | +=== Single Home Unit Case Diagram
|
|
| 618 | + |
|
| 619 | + Example: ghci -this-unit-id main ...
|
|
| 620 | + Equivalent to: ghci -unit @unitA
|
|
| 621 | + |
|
| 622 | + ┌───────────────────┐ ┌─────────────────────┐
|
|
| 623 | + │ Interactive Prompt│ │ Interactive Session │
|
|
| 624 | + │ │───────►│ │
|
|
| 625 | + │ interactive-ghci │ │ interactive-session │
|
|
| 626 | + └────────┬──────────┘ └──────────┬──────────┘
|
|
| 627 | + │ │
|
|
| 628 | + └───────────────┬──────────────┘
|
|
| 629 | + │
|
|
| 630 | + │
|
|
| 631 | + ┌────▼───┐
|
|
| 632 | + │ Unit A │
|
|
| 633 | + │ main │
|
|
| 634 | + └────────┘
|
|
| 635 | + |
|
| 636 | + |
|
| 637 | +=== Multi Home Unit Case Diagram
|
|
| 638 | + |
|
| 639 | + Example: ghci -unit @unitA -unit @unitB -unit @unitC
|
|
| 640 | + |
|
| 641 | + ┌───────────────────┐ ┌─────────────────────┐
|
|
| 642 | + │ Interactive Prompt│ │ Interactive Session │
|
|
| 643 | + │ │───────►│ │
|
|
| 644 | + │ interactive-ghci │ │ interactive-session │
|
|
| 645 | + └────────┬──────────┘ └──────────┬──────────┘
|
|
| 646 | + │ │
|
|
| 647 | + └───────────────┬──────────────┘
|
|
| 648 | + │
|
|
| 649 | + ┌─────────────┼─────────────┐
|
|
| 650 | + ┌────▼───┐ ┌────▼───┐ ┌────▼───┐
|
|
| 651 | + │ Unit A │ │ Unit B │ │ Unit C │
|
|
| 652 | + │ a-0.0 │ │ b-0.0 │ │ c-0.0 │
|
|
| 653 | + └────────┘ └────────┘ └────────┘
|
|
| 654 | + |
|
| 655 | +As we can see, this design can be scaled to an arbitrary number of Home Units.
|
|
| 656 | + |
|
| 657 | +=== 'interactiveGhciUnit' Home Unit
|
|
| 658 | + |
|
| 659 | +The 'interactiveGhciUnit' home unit is used for storing the 'DynFlags' of
|
|
| 660 | +the interactive context.
|
|
| 661 | +There is considerable overlap with the 'InteractiveContext,
|
|
| 662 | +see Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId']
|
|
| 663 | +for details.
|
|
| 664 | + |
|
| 665 | +The 'DynFlags' of the 'interactiveGhciUnit' can be modified by using `:seti`
|
|
| 666 | +commands in the GHCi session.
|
|
| 667 | + |
|
| 668 | +=== 'interactiveSessionUnit' Home Unit
|
|
| 669 | + |
|
| 670 | +The 'interactiveSessionUnit' home unit is used as a kitchen sink for Modules that
|
|
| 671 | +are not part of a home unit already.
|
|
| 672 | +When the user types ":load", it is not trivial to figure to which home unit the module
|
|
| 673 | +should be added to.
|
|
| 674 | +Especially, when there is more than home unit. Thus, we always ":load"ed modules
|
|
| 675 | +to this home unit.
|
|
| 676 | + |
|
| 677 | +The 'DynFlags' of the 'interactiveSessionUnit' can be modified via the ':set'
|
|
| 678 | +commands in the GHCi session.
|
|
| 679 | +-}
|
|
| 680 | + |
|
| 681 | +-- | Set up the multiple home unit session.
|
|
| 682 | +-- Installs a 'HomeUnitEnv' for the ghci-prompt and one for the ghci-session in the
|
|
| 683 | +-- current 'HscEnv'.
|
|
| 684 | +--
|
|
| 685 | +-- Installs the two home units 'interactiveGhciUnit' and 'interactiveSessionUnit', which
|
|
| 686 | +-- both depend on any other 'HomeUnitEnv' that is already present in the current
|
|
| 687 | +-- 'HomeUnitGraph'.
|
|
| 688 | +--
|
|
| 689 | +-- In other words, in each GHCi session, there are always at least three 'HomeUnitEnv's:
|
|
| 690 | +--
|
|
| 691 | +-- * 'interactiveGhciUnit'
|
|
| 692 | +-- * 'interactiveSessionUnit'
|
|
| 693 | +-- * 'mainUnit' (by default)
|
|
| 694 | +--
|
|
| 695 | +-- The 'interactiveGhciUnit' is the currently active unit, i.e. @hscActiveUnit hsc_env == 'interactiveGhciUnitId'@,
|
|
| 696 | +-- and it stays as the active unit for the entire duration of GHCi.
|
|
| 697 | +-- Within GHCi, you can rely on this property.
|
|
| 698 | +--
|
|
| 699 | +-- For motivation and design, see Note [Multiple Home Units aware GHCi]
|
|
| 700 | +installInteractiveHomeUnit :: GHC.GhcMonad m => m ()
|
|
| 701 | +installInteractiveHomeUnit = do
|
|
| 702 | + logger <- getLogger
|
|
| 703 | + hsc_env <- GHC.getSession
|
|
| 704 | + -- The initial set of DynFlags used for interactive evaluation is the same
|
|
| 705 | + -- as the global DynFlags, plus:
|
|
| 706 | + -- * -XExtendedDefaultRules and
|
|
| 707 | + -- * -XNoMonomorphismRestriction.
|
|
| 708 | + -- See Note [Changing language extensions for interactive evaluation] #10857
|
|
| 709 | + dflags <- getDynFlags
|
|
| 710 | + let
|
|
| 711 | + dflags0' =
|
|
| 712 | + (xopt_set_unlessExplSpec LangExt.ExtendedDefaultRules xopt_set) .
|
|
| 713 | + (xopt_set_unlessExplSpec LangExt.MonomorphismRestriction xopt_unset) $
|
|
| 714 | + dflags
|
|
| 715 | + -- Disable warnings about unused packages
|
|
| 716 | + -- It doesn't matter for the interactive session.
|
|
| 717 | + -- See Note [No unused package warnings for the interactive session]
|
|
| 718 | + dflags0 = wopt_unset dflags0' Opt_WarnUnusedPackages
|
|
| 719 | + |
|
| 720 | + -- Trivial '-package-id <uid>' flag
|
|
| 721 | + homeUnitPkgFlag uid =
|
|
| 722 | + ExposePackage
|
|
| 723 | + (unitIdString uid)
|
|
| 724 | + (UnitIdArg $ RealUnit (Definite uid))
|
|
| 725 | + (ModRenaming False [])
|
|
| 726 | + |
|
| 727 | + sessionUnitExposedFlag =
|
|
| 728 | + homeUnitPkgFlag interactiveSessionUnitId
|
|
| 729 | + |
|
| 730 | + -- Explicitly depend on all home units and 'sessionUnitExposedFlag'.
|
|
| 731 | + -- Normalise the 'dflagsPrompt', as they will be used for 'ic_dflags'
|
|
| 732 | + -- of the 'InteractiveContext'.
|
|
| 733 | + dflagsPrompt <- GHC.normaliseInteractiveDynFlags logger $
|
|
| 734 | + setHomeUnitId interactiveGhciUnitId $ dflags0
|
|
| 735 | + { packageFlags =
|
|
| 736 | + [ sessionUnitExposedFlag ] ++
|
|
| 737 | + [ homeUnitPkgFlag uid
|
|
| 738 | + | homeUnitEnv <- Foldable.toList $ hsc_HUG hsc_env
|
|
| 739 | + , Just homeUnit <- [homeUnitEnv_home_unit homeUnitEnv]
|
|
| 740 | + , let uid = homeUnitId homeUnit
|
|
| 741 | + ] ++
|
|
| 742 | + (packageFlags dflags0)
|
|
| 743 | + , importPaths = [] -- TODO @fendor: do we need this?
|
|
| 744 | + }
|
|
| 745 | + |
|
| 746 | + let
|
|
| 747 | + -- Explicitly depend on all current home units.
|
|
| 748 | + dflagsSession =
|
|
| 749 | + setHomeUnitId interactiveSessionUnitId $ dflags
|
|
| 750 | + { packageFlags =
|
|
| 751 | + [ homeUnitPkgFlag uid
|
|
| 752 | + | homeUnitEnv <- Foldable.toList $ hsc_HUG hsc_env
|
|
| 753 | + , Just homeUnit <- [homeUnitEnv_home_unit homeUnitEnv]
|
|
| 754 | + , let uid = homeUnitId homeUnit
|
|
| 755 | + ] ++
|
|
| 756 | + (packageFlags dflags)
|
|
| 757 | + , importPaths = [] -- TODO @fendor: do we need this?
|
|
| 758 | + }
|
|
| 759 | + |
|
| 760 | + let
|
|
| 761 | + cached_unit_dbs =
|
|
| 762 | + concat
|
|
| 763 | + . catMaybes
|
|
| 764 | + . fmap homeUnitEnv_unit_dbs
|
|
| 765 | + $ Foldable.toList
|
|
| 766 | + $ hsc_HUG hsc_env
|
|
| 767 | + |
|
| 768 | + all_unit_ids =
|
|
| 769 | + S.insert interactiveGhciUnitId $
|
|
| 770 | + S.insert interactiveSessionUnitId $
|
|
| 771 | + hsc_all_home_unit_ids hsc_env
|
|
| 772 | + |
|
| 773 | + ghciPromptUnit <- setupHomeUnitFor logger dflagsPrompt all_unit_ids cached_unit_dbs
|
|
| 774 | + ghciSessionUnit <- setupHomeUnitFor logger dflagsSession all_unit_ids cached_unit_dbs
|
|
| 775 | + let
|
|
| 776 | + -- Setup up the HUG, install the interactive home units
|
|
| 777 | + withInteractiveUnits =
|
|
| 778 | + HUG.unitEnv_insert interactiveGhciUnitId ghciPromptUnit
|
|
| 779 | + . HUG.unitEnv_insert interactiveSessionUnitId ghciSessionUnit
|
|
| 780 | + |
|
| 781 | + -- Finish up the setup, install the new HUG and make the 'interactiveGhciUnitId'
|
|
| 782 | + -- the active unit.
|
|
| 783 | + modifySessionM (\env -> do
|
|
| 784 | + -- Set the new HUG
|
|
| 785 | + let newEnv0 = hscUpdateHUG withInteractiveUnits env
|
|
| 786 | + -- Make sure the 'interactiveGhciUnitId' is active and 'hsc_dflags'
|
|
| 787 | + -- are populated correctly.
|
|
| 788 | + -- The 'interactiveGhciUnitId' will stay as the active unit within GHCi.
|
|
| 789 | + let newEnv1 = hscSetActiveUnitId interactiveGhciUnitId newEnv0
|
|
| 790 | + -- Use the 'DynFlags' of the 'interactiveGhciUnitId' for the 'InteractiveContext'.
|
|
| 791 | + GHC.initialiseInteractiveDynFlags dflagsPrompt newEnv1
|
|
| 792 | + )
|
|
| 793 | + |
|
| 794 | + pure ()
|
|
| 795 | + where
|
|
| 796 | + setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> [UnitDatabase UnitId] -> m HomeUnitEnv
|
|
| 797 | + setupHomeUnitFor logger dflags all_home_units cached_unit_dbs = do
|
|
| 798 | + (dbs,unit_state,home_unit,_mconstants) <-
|
|
| 799 | + liftIO $ initUnits logger dflags (Just cached_unit_dbs) all_home_units
|
|
| 800 | + hpt <- liftIO emptyHomePackageTable
|
|
| 801 | + pure (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags hpt (Just home_unit))
|
|
| 802 | + |
|
| 598 | 803 | reportError :: GhciMonad m => GhciCommandMessage -> m ()
|
| 599 | 804 | reportError err = do
|
| 600 | 805 | printError err
|
| ... | ... | @@ -933,7 +1138,7 @@ getInfoForPrompt = do |
| 933 | 1138 | | otherwise = unLoc (ideclName d)
|
| 934 | 1139 | |
| 935 | 1140 | modules_names =
|
| 936 | - ['*':(moduleNameString m) | IIModule m <- rev_imports] ++
|
|
| 1141 | + ['*':(moduleNameString (moduleName m)) | IIModule m <- rev_imports] ++
|
|
| 937 | 1142 | [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]
|
| 938 | 1143 | line = 1 + line_number st
|
| 939 | 1144 | |
| ... | ... | @@ -1971,13 +2176,27 @@ wrapDeferTypeErrors :: GHC.GhcMonad m => m a -> m a |
| 1971 | 2176 | wrapDeferTypeErrors load =
|
| 1972 | 2177 | MC.bracket
|
| 1973 | 2178 | (do
|
| 1974 | - -- Force originalFlags to avoid leaking the associated HscEnv
|
|
| 1975 | - !originalFlags <- getDynFlags
|
|
| 1976 | - void $ GHC.setProgramDynFlags $
|
|
| 1977 | - setGeneralFlag' Opt_DeferTypeErrors originalFlags
|
|
| 1978 | - return originalFlags)
|
|
| 1979 | - (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)
|
|
| 2179 | + -- Force originalHUG to avoid leaking the associated HscEnv
|
|
| 2180 | + !originalHUG <- hsc_HUG <$> GHC.getSession
|
|
| 2181 | + _ <- GHC.setProgramHUG (fmap deferTypeErrors originalHUG)
|
|
| 2182 | + return originalHUG)
|
|
| 2183 | + (\originalHUG ->
|
|
| 2184 | + -- Restore the old 'DynFlags' for each home unit.
|
|
| 2185 | + -- This makes sure that '-fdefer-type-errors' is unset again, iff it wasn't set before.
|
|
| 2186 | + modifySession (hscUpdateHUG (restoreOriginalDynFlags originalHUG)))
|
|
| 1980 | 2187 | (\_ -> load)
|
| 2188 | + where
|
|
| 2189 | + deferTypeErrors home_unit_env =
|
|
| 2190 | + home_unit_env
|
|
| 2191 | + { homeUnitEnv_dflags =
|
|
| 2192 | + setGeneralFlag' Opt_DeferTypeErrors (homeUnitEnv_dflags home_unit_env)
|
|
| 2193 | + }
|
|
| 2194 | + |
|
| 2195 | + restoreOriginalDynFlags (HUG.UnitEnvGraph old) (HUG.UnitEnvGraph new) = HUG.UnitEnvGraph $
|
|
| 2196 | + M.unionWith (\b a ->
|
|
| 2197 | + a { homeUnitEnv_dflags = homeUnitEnv_dflags b
|
|
| 2198 | + })
|
|
| 2199 | + old new
|
|
| 1981 | 2200 | |
| 1982 | 2201 | loadModule :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag
|
| 1983 | 2202 | loadModule fs = do
|
| ... | ... | @@ -1986,7 +2205,7 @@ loadModule fs = do |
| 1986 | 2205 | |
| 1987 | 2206 | -- | @:load@ command
|
| 1988 | 2207 | loadModule_ :: GhciMonad m => [FilePath] -> m ()
|
| 1989 | -loadModule_ fs = void $ loadModule (zip3 fs (repeat Nothing) (repeat Nothing))
|
|
| 2208 | +loadModule_ fs = void $ loadModule (zip3 fs (repeat (Just interactiveSessionUnitId)) (repeat Nothing))
|
|
| 1990 | 2209 | |
| 1991 | 2210 | loadModuleDefer :: GhciMonad m => [FilePath] -> m ()
|
| 1992 | 2211 | loadModuleDefer = wrapDeferTypeErrors . loadModule_
|
| ... | ... | @@ -2030,7 +2249,8 @@ addModule :: GhciMonad m => [FilePath] -> m () |
| 2030 | 2249 | addModule files = do
|
| 2031 | 2250 | revertCAFs -- always revert CAFs on load/add.
|
| 2032 | 2251 | files' <- mapM expandPath files
|
| 2033 | - targets <- mapM (\m -> GHC.guessTarget m Nothing Nothing) files'
|
|
| 2252 | + -- New targets are always added to the 'interactiveSessionUnitId' 'HomeUnitEnv'.
|
|
| 2253 | + targets <- mapM (\m -> GHC.guessTarget m (Just interactiveSessionUnitId) Nothing) files'
|
|
| 2034 | 2254 | targets' <- filterM checkTarget targets
|
| 2035 | 2255 | -- remove old targets with the same id; e.g. for :add *M
|
| 2036 | 2256 | mapM_ GHC.removeTarget [ tid | Target { targetId = tid } <- targets' ]
|
| ... | ... | @@ -2063,7 +2283,8 @@ addModule files = do |
| 2063 | 2283 | unAddModule :: GhciMonad m => [FilePath] -> m ()
|
| 2064 | 2284 | unAddModule files = do
|
| 2065 | 2285 | files' <- mapM expandPath files
|
| 2066 | - targets <- mapM (\m -> GHC.guessTarget m Nothing Nothing) files'
|
|
| 2286 | + -- New targets are always added to the 'interactiveSessionUnitId' 'HomeUnitEnv'.
|
|
| 2287 | + targets <- mapM (\m -> GHC.guessTarget m (Just interactiveSessionUnitId) Nothing) files'
|
|
| 2067 | 2288 | let removals = [ tid | Target { targetId = tid } <- targets ]
|
| 2068 | 2289 | mapM_ GHC.removeTarget removals
|
| 2069 | 2290 | _ <- doLoadAndCollectInfo (Unadd $ length removals) LoadAllTargets
|
| ... | ... | @@ -2105,7 +2326,7 @@ doLoadAndCollectInfo load_type howmuch = do |
| 2105 | 2326 | -- MP: :set +c code path only works in single package mode atm, hence
|
| 2106 | 2327 | -- this call to isLoaded is ok. collectInfo needs to be modified further to
|
| 2107 | 2328 | -- work with :set +c so I have punted on that for now.
|
| 2108 | - loaded <- filterM GHC.isLoaded (map ms_mod_name mod_summaries)
|
|
| 2329 | + loaded <- filterM GHC.isLoadedHomeModule (map ms_mod mod_summaries)
|
|
| 2109 | 2330 | v <- mod_infos <$> getGHCiState
|
| 2110 | 2331 | !newInfos <- collectInfo v loaded
|
| 2111 | 2332 | modifyGHCiState (\st -> st { mod_infos = newInfos })
|
| ... | ... | @@ -2187,7 +2408,7 @@ setContextAfterLoad keep_ctxt (Just graph) = do |
| 2187 | 2408 | -- We import the module with a * iff
|
| 2188 | 2409 | -- - it is interpreted, and
|
| 2189 | 2410 | -- - -XSafe is off (it doesn't allow *-imports)
|
| 2190 | - let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)]
|
|
| 2411 | + let new_ctx | star_ok = [mkIIModule m]
|
|
| 2191 | 2412 | | otherwise = [mkIIDecl (GHC.moduleName m)]
|
| 2192 | 2413 | setContextKeepingPackageModules keep_ctxt new_ctx
|
| 2193 | 2414 | |
| ... | ... | @@ -2607,7 +2828,7 @@ guessCurrentModule cmd = do |
| 2607 | 2828 | imports <- GHC.getContext
|
| 2608 | 2829 | case imports of
|
| 2609 | 2830 | [] -> throwGhcException $ CmdLineError (':' : cmd ++ ": no current module")
|
| 2610 | - IIModule m : _ -> GHC.findQualifiedModule NoPkgQual m
|
|
| 2831 | + IIModule m : _ -> pure m
|
|
| 2611 | 2832 | IIDecl d : _ -> do
|
| 2612 | 2833 | pkgqual <- GHC.renameRawPkgQualM (unLoc $ ideclName d) (ideclPkgQual d)
|
| 2613 | 2834 | GHC.findQualifiedModule pkgqual (unLoc (ideclName d))
|
| ... | ... | @@ -2628,7 +2849,7 @@ browseModule bang modl exports_only = do |
| 2628 | 2849 | then pure $ GHC.modInfoExports mod_info
|
| 2629 | 2850 | else do
|
| 2630 | 2851 | hsc_env <- GHC.getSession
|
| 2631 | - mmod_env <- liftIO $ mkTopLevEnv hsc_env (moduleName modl)
|
|
| 2852 | + mmod_env <- liftIO $ mkTopLevEnv hsc_env modl
|
|
| 2632 | 2853 | case mmod_env of
|
| 2633 | 2854 | Left err -> throwGhcException (CmdLineError (GHC.moduleNameString (GHC.moduleName modl) ++ " " ++ err))
|
| 2634 | 2855 | Right mod_env -> pure $ map greName . globalRdrEnvElts $ mod_env
|
| ... | ... | @@ -2737,8 +2958,9 @@ addModulesToContext starred unstarred = restoreContextOnFailure $ do |
| 2737 | 2958 | |
| 2738 | 2959 | addModulesToContext_ :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
|
| 2739 | 2960 | addModulesToContext_ starred unstarred = do
|
| 2740 | - mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)
|
|
| 2741 | - setGHCContextFromGHCiState
|
|
| 2961 | + starredModules <- traverse lookupModuleName starred
|
|
| 2962 | + mapM_ addII (map mkIIModule starredModules ++ map mkIIDecl unstarred)
|
|
| 2963 | + setGHCContextFromGHCiState
|
|
| 2742 | 2964 | |
| 2743 | 2965 | remModulesFromContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()
|
| 2744 | 2966 | remModulesFromContext starred unstarred = do
|
| ... | ... | @@ -2804,14 +3026,14 @@ checkAdd ii = do |
| 2804 | 3026 | dflags <- getDynFlags
|
| 2805 | 3027 | let safe = safeLanguageOn dflags
|
| 2806 | 3028 | case ii of
|
| 2807 | - IIModule modname
|
|
| 3029 | + IIModule mod
|
|
| 2808 | 3030 | | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"
|
| 2809 | - | otherwise -> wantInterpretedModuleName modname >> return ()
|
|
| 3031 | + | otherwise -> checkInterpretedModule mod >> return ()
|
|
| 2810 | 3032 | |
| 2811 | 3033 | IIDecl d -> do
|
| 2812 | 3034 | let modname = unLoc (ideclName d)
|
| 2813 | 3035 | pkgqual <- GHC.renameRawPkgQualM modname (ideclPkgQual d)
|
| 2814 | - m <- GHC.lookupQualifiedModule pkgqual modname
|
|
| 3036 | + m <- lookupQualifiedModuleName pkgqual modname
|
|
| 2815 | 3037 | when safe $ do
|
| 2816 | 3038 | t <- GHC.isModuleTrusted m
|
| 2817 | 3039 | unless t $ throwGhcException $ ProgramError $ ""
|
| ... | ... | @@ -2874,13 +3096,13 @@ getImplicitPreludeImports iidecls = do |
| 2874 | 3096 | -- -----------------------------------------------------------------------------
|
| 2875 | 3097 | -- Utils on InteractiveImport
|
| 2876 | 3098 | |
| 2877 | -mkIIModule :: ModuleName -> InteractiveImport
|
|
| 3099 | +mkIIModule :: Module -> InteractiveImport
|
|
| 2878 | 3100 | mkIIModule = IIModule
|
| 2879 | 3101 | |
| 2880 | 3102 | mkIIDecl :: ModuleName -> InteractiveImport
|
| 2881 | 3103 | mkIIDecl = IIDecl . simpleImportDecl
|
| 2882 | 3104 | |
| 2883 | -iiModules :: [InteractiveImport] -> [ModuleName]
|
|
| 3105 | +iiModules :: [InteractiveImport] -> [Module]
|
|
| 2884 | 3106 | iiModules is = [m | IIModule m <- is]
|
| 2885 | 3107 | |
| 2886 | 3108 | isIIModule :: InteractiveImport -> Bool
|
| ... | ... | @@ -2888,7 +3110,7 @@ isIIModule (IIModule _) = True |
| 2888 | 3110 | isIIModule _ = False
|
| 2889 | 3111 | |
| 2890 | 3112 | iiModuleName :: InteractiveImport -> ModuleName
|
| 2891 | -iiModuleName (IIModule m) = m
|
|
| 3113 | +iiModuleName (IIModule m) = moduleName m
|
|
| 2892 | 3114 | iiModuleName (IIDecl d) = unLoc (ideclName d)
|
| 2893 | 3115 | |
| 2894 | 3116 | preludeModuleName :: ModuleName
|
| ... | ... | @@ -2990,8 +3212,23 @@ showOptions show_all |
| 2990 | 3212 | then text "none."
|
| 2991 | 3213 | else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
|
| 2992 | 3214 | ))
|
| 2993 | - liftIO $ showDynFlags show_all dflags
|
|
| 2994 | - |
|
| 3215 | + mapNonInteractiveHomeUnitsM (liftIO . showDynFlags show_all)
|
|
| 3216 | + |
|
| 3217 | +mapNonInteractiveHomeUnitsM :: GHC.GhcMonad m => (DynFlags -> m ()) -> m ()
|
|
| 3218 | +mapNonInteractiveHomeUnitsM printer = do
|
|
| 3219 | + hug <- hsc_HUG <$> GHC.getSession
|
|
| 3220 | + singleOrMultipleHomeUnits
|
|
| 3221 | + $ map (\(uid, homeUnit) -> (uid, homeUnitEnv_dflags homeUnit))
|
|
| 3222 | + $ filter (\(uid, _) -> uid /= interactiveSessionUnitId
|
|
| 3223 | + && uid /= interactiveGhciUnitId)
|
|
| 3224 | + $ HUG.unitEnv_assocs hug
|
|
| 3225 | + where
|
|
| 3226 | + singleOrMultipleHomeUnits [] =
|
|
| 3227 | + liftIO $ putStrLn "GHCi: internal error - no home unit configured"
|
|
| 3228 | + singleOrMultipleHomeUnits [(_, dflags)] = printer dflags
|
|
| 3229 | + singleOrMultipleHomeUnits xs = mapM_ (\(uid, dflags) -> do
|
|
| 3230 | + liftIO $ putStrLn (showSDoc dflags (text "Unit ID:" <+> ppr uid))
|
|
| 3231 | + printer dflags) xs
|
|
| 2995 | 3232 | |
| 2996 | 3233 | showDynFlags :: Bool -> DynFlags -> IO ()
|
| 2997 | 3234 | showDynFlags show_all dflags = do
|
| ... | ... | @@ -3117,69 +3354,200 @@ setOptions wds = |
| 3117 | 3354 | -- then, dynamic flags
|
| 3118 | 3355 | when (not (null minus_opts)) $ newDynFlags False minus_opts
|
| 3119 | 3356 | |
| 3120 | --- | newDynFlags will *not* read package environment files, therefore we
|
|
| 3121 | --- use 'parseDynamicFlagsCmdLine' rather than 'parseDynamicFlags'. This
|
|
| 3122 | --- function is called very often and results in repeatedly loading
|
|
| 3123 | --- environment files (see #19650)
|
|
| 3357 | +-- Note [No unused package warnings for the interactive session]
|
|
| 3358 | +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
| 3359 | +--
|
|
| 3360 | +-- The interactive session (also called "interactive-prompt" occassionally) should not
|
|
| 3361 | +-- report unused packages, as it will essentially always report packages
|
|
| 3362 | +-- as unused.
|
|
| 3363 | +-- The "interactive-prompt" doesn't contain any 'Module's, so most packages
|
|
| 3364 | +-- are unused.
|
|
| 3365 | +-- As this would flood the user with warnings they can't do anything about,
|
|
| 3366 | +-- we decide to unconditionally turn off the warning 'Opt_WarnUnusedPackages'.
|
|
| 3367 | +--
|
|
| 3368 | +-- Unused packages in GHCi are still reported via the 'interactive-session' unit.
|
|
| 3369 | +-- See Note [Multiple Home Units aware GHCi] for an explanation about the
|
|
| 3370 | +-- "interactive-prompt" and 'interactive-session' unit.
|
|
| 3371 | + |
|
| 3372 | +-- | 'newDynFlags' adds the given user options to the session.
|
|
| 3373 | +--
|
|
| 3374 | +-- If 'True' is passed, we add the options only to the interactive 'DynFlags'.
|
|
| 3375 | +-- Otherwise, the options are added to each 'HomeUnitEnv' in the current session.
|
|
| 3376 | +--
|
|
| 3377 | +-- This function will check whether we need to re-initialise the 'UnitState',
|
|
| 3378 | +-- for example when the user writes ':set -package containers'.
|
|
| 3379 | +--
|
|
| 3380 | +-- Any warnings during parsing, or validation of the new 'DynFlags' will be
|
|
| 3381 | +-- directly reported to the user.
|
|
| 3124 | 3382 | newDynFlags :: GhciMonad m => Bool -> [String] -> m ()
|
| 3125 | 3383 | newDynFlags interactive_only minus_opts = do
|
| 3126 | - let lopts = map noLoc minus_opts
|
|
| 3384 | + let lopts = map noLoc minus_opts
|
|
| 3127 | 3385 | |
| 3128 | - logger <- getLogger
|
|
| 3129 | - idflags0 <- GHC.getInteractiveDynFlags
|
|
| 3130 | - (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine logger idflags0 lopts
|
|
| 3386 | + case interactive_only of
|
|
| 3387 | + True -> addToInteractiveDynFlags lopts
|
|
| 3388 | + False -> addToProgramDynFlags lopts
|
|
| 3131 | 3389 | |
| 3132 | - liftIO $ printOrThrowDiagnostics logger (initPrintConfig idflags1) (initDiagOpts idflags1) (GhcDriverMessage <$> warns)
|
|
| 3390 | + idflags <- hsc_dflags <$> GHC.getSession
|
|
| 3391 | + installInteractivePrint (interactivePrint idflags) False
|
|
| 3392 | + |
|
| 3393 | +-- | Add the given options to the interactive 'DynFlags'.
|
|
| 3394 | +-- This function will normalise and validate the 'DynFlags' and report warnings
|
|
| 3395 | +-- directly to the user.
|
|
| 3396 | +--
|
|
| 3397 | +-- Updates both the 'hsc_dflags' of 'HscEnv', and the 'ic_dflags' of the 'InteractiveContext'.
|
|
| 3398 | +--
|
|
| 3399 | +-- 'addToInteractiveDynFlags' will *not* read package environment files, therefore we
|
|
| 3400 | +-- use 'parseDynamicFlagsCmdLine' rather than 'parseDynamicFlags'. This
|
|
| 3401 | +-- function is called very often and results in repeatedly loading
|
|
| 3402 | +-- environment files (see #19650)
|
|
| 3403 | +addToInteractiveDynFlags :: GhciMonad m => [Located String] -> m ()
|
|
| 3404 | +addToInteractiveDynFlags lopts = do
|
|
| 3405 | + logger <- getLogger
|
|
| 3406 | + idflags0 <- hsc_dflags <$> GHC.getSession
|
|
| 3407 | + (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine logger idflags0 lopts
|
|
| 3408 | + |
|
| 3409 | + liftIO $ printOrThrowDiagnostics logger (initPrintConfig idflags1) (initDiagOpts idflags1) (GhcDriverMessage <$> warns)
|
|
| 3410 | + when (not $ null leftovers) (unknownFlagsErr $ map unLoc leftovers)
|
|
| 3411 | + |
|
| 3412 | + when (packageFlagsChanged idflags1 idflags0) $ do
|
|
| 3413 | + liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
|
|
| 3414 | + |
|
| 3415 | + GHC.setInteractiveDynFlags idflags1
|
|
| 3416 | + idflags_norm <- ic_dflags . hsc_IC <$> GHC.getSession
|
|
| 3417 | + -- TODO @fendor: why not 'setProgramHUG_'?
|
|
| 3418 | + _ <- GHC.setProgramDynFlags idflags_norm
|
|
| 3419 | + pure ()
|
|
| 3420 | + |
|
| 3421 | +-- | Add the given options to all 'DynFlags' in the 'HomeUnitGraph'.
|
|
| 3422 | +-- This function will validate the 'DynFlags' and report warnings directly to the user.
|
|
| 3423 | +--
|
|
| 3424 | +-- We additionally normalise the 'DynFlags' for the 'interactiveGhciUnitId' for use
|
|
| 3425 | +-- in the 'InteractiveContext'.
|
|
| 3426 | +--
|
|
| 3427 | +-- 'addToProgramDynFlags' will *not* read package environment files, therefore we
|
|
| 3428 | +-- use 'parseDynamicFlagsCmdLine' rather than 'parseDynamicFlags'. This
|
|
| 3429 | +-- function is called very often and results in repeatedly loading
|
|
| 3430 | +-- environment files (see #19650)
|
|
| 3431 | +addToProgramDynFlags :: GhciMonad m => [Located String] -> m ()
|
|
| 3432 | +addToProgramDynFlags lopts = do
|
|
| 3433 | + logger <- getLogger
|
|
| 3434 | + initial_hug <- hsc_HUG <$> GHC.getSession
|
|
| 3435 | + -- Update the 'DynFlags' of each 'HomeUnitEnv'.
|
|
| 3436 | + -- Parse the new 'DynFlags', and report potential issues once.
|
|
| 3437 | + -- Arguably, we may want to report issues for each non-builtin 'HomeUnitEnv'
|
|
| 3438 | + -- individually.
|
|
| 3439 | + updates <- HUG.unitEnv_traverseWithKey (\uid homeUnitEnv -> do
|
|
| 3440 | + let oldFlags = HUG.homeUnitEnv_dflags homeUnitEnv
|
|
| 3441 | + (newFlags, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine logger oldFlags lopts
|
|
| 3442 | + -- We only want to report inconsistencies and warnings once.
|
|
| 3443 | + -- Thus, we do it only once for the 'interactiveGhciUnitId'
|
|
| 3444 | + when (uid == interactiveGhciUnitId) $ do
|
|
| 3445 | + liftIO $ printOrThrowDiagnostics logger (initPrintConfig newFlags) (initDiagOpts newFlags) (GhcDriverMessage <$> warns)
|
|
| 3133 | 3446 | when (not $ null leftovers) (unknownFlagsErr $ map unLoc leftovers)
|
| 3134 | 3447 | |
| 3135 | - when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do
|
|
| 3136 | - liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"
|
|
| 3137 | - GHC.setInteractiveDynFlags idflags1
|
|
| 3138 | - installInteractivePrint (interactivePrint idflags1) False
|
|
| 3139 | - |
|
| 3140 | - dflags0 <- getDynFlags
|
|
| 3141 | - |
|
| 3142 | - when (not interactive_only) $ do
|
|
| 3143 | - (dflags1, _, _) <- liftIO $ DynFlags.parseDynamicFlagsCmdLine logger dflags0 lopts
|
|
| 3144 | - must_reload <- GHC.setProgramDynFlags dflags1
|
|
| 3145 | - |
|
| 3146 | - -- if the package flags changed, reset the context and link
|
|
| 3147 | - -- the new packages.
|
|
| 3148 | - hsc_env <- GHC.getSession
|
|
| 3149 | - let dflags2 = hsc_dflags hsc_env
|
|
| 3150 | - let interp = hscInterp hsc_env
|
|
| 3151 | - when (packageFlagsChanged dflags2 dflags0) $ do
|
|
| 3152 | - when (verbosity dflags2 > 0) $
|
|
| 3153 | - liftIO . putStrLn $
|
|
| 3154 | - "package flags have changed, resetting and loading new packages..."
|
|
| 3155 | - -- Clear caches and eventually defined breakpoints. (#1620)
|
|
| 3156 | - clearCaches
|
|
| 3157 | - when must_reload $ do
|
|
| 3158 | - let units = preloadUnits (hsc_units hsc_env)
|
|
| 3159 | - liftIO $ Loader.loadPackages interp hsc_env units
|
|
| 3160 | - -- package flags changed, we can't re-use any of the old context
|
|
| 3161 | - setContextAfterLoad False Nothing
|
|
| 3162 | - -- and copy the package flags to the interactive DynFlags
|
|
| 3163 | - idflags <- GHC.getInteractiveDynFlags
|
|
| 3164 | - GHC.setInteractiveDynFlags
|
|
| 3165 | - idflags{ packageFlags = packageFlags dflags2 }
|
|
| 3166 | - |
|
| 3167 | - let ld0length = length $ ldInputs dflags0
|
|
| 3168 | - fmrk0length = length $ cmdlineFrameworks dflags0
|
|
| 3169 | - |
|
| 3170 | - newLdInputs = drop ld0length (ldInputs dflags2)
|
|
| 3171 | - newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)
|
|
| 3172 | - |
|
| 3173 | - dflags' = dflags2 { ldInputs = newLdInputs
|
|
| 3174 | - , cmdlineFrameworks = newCLFrameworks
|
|
| 3175 | - }
|
|
| 3176 | - hsc_env' = hscSetFlags dflags' hsc_env
|
|
| 3177 | - |
|
| 3178 | - when (not (null newLdInputs && null newCLFrameworks)) $
|
|
| 3179 | - liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env'
|
|
| 3180 | - |
|
| 3181 | - return ()
|
|
| 3448 | + -- Special Logic!
|
|
| 3449 | + -- Currently, the interactive 'DynFlags' have additional restrictions,
|
|
| 3450 | + -- for example modifying package flags is not supported!
|
|
| 3451 | + -- The interactive 'DynFlags' get normalised to uphold this restriction.
|
|
| 3452 | + -- As a special precaution, we also don't want to report unusued packages warnings
|
|
| 3453 | + -- for the interactive session.
|
|
| 3454 | + -- See Note [No unused package warnings for the interactive session]
|
|
| 3455 | + --
|
|
| 3456 | + -- See Note [Multiple Home Units aware GHCi] for details about how
|
|
| 3457 | + -- the interactive session is structured.
|
|
| 3458 | + newFlags' <-
|
|
| 3459 | + if uid == interactiveGhciUnitId
|
|
| 3460 | + then do
|
|
| 3461 | + -- See Note [No unused package warnings for the interactive session]
|
|
| 3462 | + let icdflags1 = wopt_unset newFlags Opt_WarnUnusedPackages
|
|
| 3463 | + GHC.normaliseInteractiveDynFlags logger icdflags1
|
|
| 3464 | + else
|
|
| 3465 | + pure newFlags
|
|
| 3466 | + pure (homeUnitEnv { homeUnitEnv_dflags = newFlags' })
|
|
| 3467 | + )
|
|
| 3468 | + initial_hug
|
|
| 3469 | + -- Update the HUG! This might force us to reload the 'UnitState' of each 'HomeUnitEnv'
|
|
| 3470 | + -- if package flags were changed.
|
|
| 3471 | + must_reload <- GHC.setProgramHUG_ True updates
|
|
| 3472 | + |
|
| 3473 | + -- Initialise the Interactive DynFlags.
|
|
| 3474 | + -- Sets the 'ic_dflags' and initialises the 'ic_plugins'.
|
|
| 3475 | + -- See Note [Relation between the 'InteractiveContext' and 'interactiveGhciUnitId']
|
|
| 3476 | + icdflags <- hsc_dflags <$> GHC.getSession
|
|
| 3477 | + modifySessionM (GHC.initialiseInteractiveDynFlags icdflags)
|
|
| 3478 | + |
|
| 3479 | + -- if the package flags changed, reset the context and link
|
|
| 3480 | + -- the new packages.
|
|
| 3481 | + hsc_env <- GHC.getSession
|
|
| 3482 | + let dflags2 = hsc_dflags hsc_env
|
|
| 3483 | + when must_reload $ do
|
|
| 3484 | + when (verbosity dflags2 > 0) $
|
|
| 3485 | + liftIO . putStrLn $
|
|
| 3486 | + "package flags have changed, resetting and loading new packages..."
|
|
| 3487 | + |
|
| 3488 | + -- Clear caches and eventually defined breakpoints. (#1620)
|
|
| 3489 | + clearCaches
|
|
| 3182 | 3490 | |
| 3491 | + reloadPackages hsc_env
|
|
| 3492 | + |
|
| 3493 | + reloadLinkerOptions hsc_env initial_hug
|
|
| 3494 | + |
|
| 3495 | +reloadPackages :: GhciMonad m => HscEnv -> m ()
|
|
| 3496 | +reloadPackages hsc_env = do
|
|
| 3497 | + let
|
|
| 3498 | + units =
|
|
| 3499 | + concatMap (preloadUnits . HUG.homeUnitEnv_units)
|
|
| 3500 | + (Foldable.toList $ hsc_HUG hsc_env)
|
|
| 3501 | + liftIO $ Loader.loadPackages (hscInterp hsc_env) hsc_env units
|
|
| 3502 | + -- package flags changed, we can't re-use any of the old context
|
|
| 3503 | + setContextAfterLoad False Nothing
|
|
| 3504 | + |
|
| 3505 | +-- | Reload the linker options.
|
|
| 3506 | +--
|
|
| 3507 | +-- Synopsis: @'reloadLinkerOptions' hsc_env old_hug@
|
|
| 3508 | +--
|
|
| 3509 | +-- After the HUG is modified, the linker may need to be reloaded.
|
|
| 3510 | +-- The linker is reloaded via 'loadCmdLineLibs', if the library inputs
|
|
| 3511 | +-- have changed.
|
|
| 3512 | +-- To determine whether the library inputs have changed, we need the
|
|
| 3513 | +-- old HUG, which is passed as the argument 'old_hug'.
|
|
| 3514 | +--
|
|
| 3515 | +-- This function will crash, if the 'old_hug' doesn't have exactly
|
|
| 3516 | +-- the same keys has the given 'hsc_env'. I.e.
|
|
| 3517 | +--
|
|
| 3518 | +-- @
|
|
| 3519 | +-- HUG.unitEnv_keys old_hug == HUG.unitEnv_keys (hsc_HUG hsc_env)
|
|
| 3520 | +-- @
|
|
| 3521 | +reloadLinkerOptions :: MonadIO m => HscEnv -> HomeUnitGraph -> m ()
|
|
| 3522 | +reloadLinkerOptions hsc_env old_hug = do
|
|
| 3523 | + let
|
|
| 3524 | + new_hug = hsc_HUG hsc_env
|
|
| 3525 | + let
|
|
| 3526 | + (needs_updates, updated_hug) = HUG.unitEnv_traverseWithKey (\key unitEnv ->
|
|
| 3527 | + let
|
|
| 3528 | + old_flags = homeUnitEnv_dflags (HUG.unitEnv_lookup key old_hug)
|
|
| 3529 | + new_flags = homeUnitEnv_dflags unitEnv
|
|
| 3530 | + ld0length = length $ ldInputs old_flags
|
|
| 3531 | + fmrk0length = length $ cmdlineFrameworks old_flags
|
|
| 3532 | + |
|
| 3533 | + newLdInputs = drop ld0length (ldInputs new_flags)
|
|
| 3534 | + newCLFrameworks = drop fmrk0length (cmdlineFrameworks new_flags)
|
|
| 3535 | + |
|
| 3536 | + dflags' = new_flags { ldInputs = newLdInputs
|
|
| 3537 | + , cmdlineFrameworks = newCLFrameworks
|
|
| 3538 | + }
|
|
| 3539 | + in
|
|
| 3540 | + (S.Any (not (null newLdInputs && null newCLFrameworks)),
|
|
| 3541 | + unitEnv { homeUnitEnv_dflags = dflags' })
|
|
| 3542 | + ) new_hug
|
|
| 3543 | + |
|
| 3544 | + hsc_env' =
|
|
| 3545 | + hscSetActiveUnitId (hscActiveUnitId hsc_env)
|
|
| 3546 | + $ hscUpdateHUG (const updated_hug)
|
|
| 3547 | + $ hsc_env
|
|
| 3548 | + |
|
| 3549 | + when (S.getAny needs_updates) $
|
|
| 3550 | + liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env'
|
|
| 3183 | 3551 | |
| 3184 | 3552 | unknownFlagsErr :: GhciMonad m => [String] -> m ()
|
| 3185 | 3553 | unknownFlagsErr fs = mapM_ (\f -> reportError (GhciUnknownFlag f (suggestions f))) fs
|
| ... | ... | @@ -3261,7 +3629,6 @@ showCmd "" = showOptions False |
| 3261 | 3629 | showCmd "-a" = showOptions True
|
| 3262 | 3630 | showCmd str = do
|
| 3263 | 3631 | st <- getGHCiState
|
| 3264 | - dflags <- getDynFlags
|
|
| 3265 | 3632 | hsc_env <- GHC.getSession
|
| 3266 | 3633 | |
| 3267 | 3634 | let lookupCmd :: String -> Maybe (m ())
|
| ... | ... | @@ -3299,8 +3666,10 @@ showCmd str = do |
| 3299 | 3666 | case words str of
|
| 3300 | 3667 | [w] | Just action <- lookupCmd w -> action
|
| 3301 | 3668 | |
| 3302 | - _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]
|
|
| 3303 | - in throwGhcException $ CmdLineError $ showSDoc dflags
|
|
| 3669 | + _ -> do
|
|
| 3670 | + let helpCmds = [ text name | (True, name, _) <- cmds ]
|
|
| 3671 | + dflags <- getDynFlags
|
|
| 3672 | + throwGhcException $ CmdLineError $ showSDoc dflags
|
|
| 3304 | 3673 | $ hang (text "syntax:") 4
|
| 3305 | 3674 | $ hang (text ":show") 6
|
| 3306 | 3675 | $ brackets (fsep $ punctuate (text " |") helpCmds)
|
| ... | ... | @@ -3321,7 +3690,7 @@ showImports = do |
| 3321 | 3690 | trans_ctx = transient_ctx st
|
| 3322 | 3691 | |
| 3323 | 3692 | show_one (IIModule star_m)
|
| 3324 | - = ":module +*" ++ moduleNameString star_m
|
|
| 3693 | + = ":module +*" ++ moduleNameString (moduleName star_m)
|
|
| 3325 | 3694 | show_one (IIDecl imp) = showPpr dflags imp
|
| 3326 | 3695 | |
| 3327 | 3696 | prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)
|
| ... | ... | @@ -3427,16 +3796,14 @@ pprStopped res = |
| 3427 | 3796 | mb_mod_name = moduleName <$> ibi_tick_mod <$> GHC.resumeBreakpointId res
|
| 3428 | 3797 | |
| 3429 | 3798 | showUnits :: GHC.GhcMonad m => m ()
|
| 3430 | -showUnits = do
|
|
| 3431 | - dflags <- getDynFlags
|
|
| 3799 | +showUnits = mapNonInteractiveHomeUnitsM $ \dflags -> do
|
|
| 3432 | 3800 | let pkg_flags = packageFlags dflags
|
| 3433 | 3801 | liftIO $ putStrLn $ showSDoc dflags $
|
| 3434 | 3802 | text ("active package flags:"++if null pkg_flags then " none" else "") $$
|
| 3435 | 3803 | nest 2 (vcat (map pprFlag pkg_flags))
|
| 3436 | 3804 | |
| 3437 | 3805 | showPaths :: GHC.GhcMonad m => m ()
|
| 3438 | -showPaths = do
|
|
| 3439 | - dflags <- getDynFlags
|
|
| 3806 | +showPaths = mapNonInteractiveHomeUnitsM $ \dflags -> do
|
|
| 3440 | 3807 | liftIO $ do
|
| 3441 | 3808 | cwd <- getCurrentDirectory
|
| 3442 | 3809 | putStrLn $ showSDoc dflags $
|
| ... | ... | @@ -3448,7 +3815,7 @@ showPaths = do |
| 3448 | 3815 | nest 2 (vcat (map text ipaths))
|
| 3449 | 3816 | |
| 3450 | 3817 | showLanguages :: GHC.GhcMonad m => m ()
|
| 3451 | -showLanguages = getDynFlags >>= liftIO . showLanguages' False
|
|
| 3818 | +showLanguages = mapNonInteractiveHomeUnitsM $ liftIO . showLanguages' False
|
|
| 3452 | 3819 | |
| 3453 | 3820 | showiLanguages :: GHC.GhcMonad m => m ()
|
| 3454 | 3821 | showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False
|
| ... | ... | @@ -3627,11 +3994,11 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000 |
| 3627 | 3994 | filterM GHC.moduleIsInterpreted hmods
|
| 3628 | 3995 | |
| 3629 | 3996 | -- Return all possible bids for a given Module
|
| 3630 | - bidsByModule :: GhciMonad m => [ModuleName] -> Module -> m [String]
|
|
| 3997 | + bidsByModule :: GhciMonad m => [Module] -> Module -> m [String]
|
|
| 3631 | 3998 | bidsByModule nonquals mod = do
|
| 3632 | 3999 | (_, decls) <- getModBreak mod
|
| 3633 | 4000 | let bids = nub $ declPath <$> elems decls
|
| 3634 | - pure $ case (moduleName mod) `elem` nonquals of
|
|
| 4001 | + pure $ case mod `elem` nonquals of
|
|
| 3635 | 4002 | True -> bids
|
| 3636 | 4003 | False -> (combineModIdent (showModule mod)) <$> bids
|
| 3637 | 4004 | |
| ... | ... | @@ -4036,8 +4403,7 @@ breakSwitch (arg1:rest) |
| 4036 | 4403 | | all isDigit arg1 = do
|
| 4037 | 4404 | imports <- GHC.getContext
|
| 4038 | 4405 | case iiModules imports of
|
| 4039 | - (mn : _) -> do
|
|
| 4040 | - md <- lookupModuleName mn
|
|
| 4406 | + (md : _) -> do
|
|
| 4041 | 4407 | breakByModuleLine md (read arg1) rest
|
| 4042 | 4408 | [] -> do
|
| 4043 | 4409 | liftIO $ putStrLn "No modules are loaded with debugging support."
|
| ... | ... | @@ -4169,8 +4535,7 @@ list2 [arg] | all isDigit arg = do |
| 4169 | 4535 | case iiModules imports of
|
| 4170 | 4536 | [] -> liftIO $ putStrLn "No module to list"
|
| 4171 | 4537 | (mn : _) -> do
|
| 4172 | - md <- lookupModuleName mn
|
|
| 4173 | - listModuleLine md (read arg)
|
|
| 4538 | + listModuleLine mn (read arg)
|
|
| 4174 | 4539 | list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
|
| 4175 | 4540 | md <- wantInterpretedModule arg1
|
| 4176 | 4541 | listModuleLine md (read arg2)
|
| ... | ... | @@ -4426,7 +4791,20 @@ lookupModule :: GHC.GhcMonad m => String -> m Module |
| 4426 | 4791 | lookupModule mName = lookupModuleName (GHC.mkModuleName mName)
|
| 4427 | 4792 | |
| 4428 | 4793 | lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module
|
| 4429 | -lookupModuleName mName = GHC.lookupQualifiedModule NoPkgQual mName
|
|
| 4794 | +lookupModuleName mName = lookupQualifiedModuleName NoPkgQual mName
|
|
| 4795 | + |
|
| 4796 | +lookupQualifiedModuleName :: GHC.GhcMonad m => PkgQual -> ModuleName -> m Module
|
|
| 4797 | +lookupQualifiedModuleName qual modl = do
|
|
| 4798 | + GHC.lookupAllQualifiedModuleNames qual modl >>= \case
|
|
| 4799 | + [] -> throwGhcException (CmdLineError ("module '" ++ str ++ "' could not be found."))
|
|
| 4800 | + [m] -> pure m
|
|
| 4801 | + ms -> throwGhcException (CmdLineError ("module name '" ++ str ++ "' is ambiguous:\n" ++ errorMsg ms))
|
|
| 4802 | + where
|
|
| 4803 | + str = moduleNameString modl
|
|
| 4804 | + errorMsg ms = intercalate "\n"
|
|
| 4805 | + [ "- " ++ unitIdString (toUnitId (moduleUnit m)) ++ ":" ++ moduleNameString (moduleName m)
|
|
| 4806 | + | m <- ms
|
|
| 4807 | + ]
|
|
| 4430 | 4808 | |
| 4431 | 4809 | isMainUnitModule :: Module -> Bool
|
| 4432 | 4810 | isMainUnitModule m = GHC.moduleUnit m == mainUnit
|
| ... | ... | @@ -4476,15 +4854,19 @@ wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str) |
| 4476 | 4854 | |
| 4477 | 4855 | wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module
|
| 4478 | 4856 | wantInterpretedModuleName modname = do
|
| 4479 | - modl <- lookupModuleName modname
|
|
| 4480 | - let str = moduleNameString modname
|
|
| 4481 | - home_unit <- hsc_home_unit <$> GHC.getSession
|
|
| 4482 | - unless (isHomeModule home_unit modl) $
|
|
| 4483 | - throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
|
|
| 4484 | - is_interpreted <- GHC.moduleIsInterpreted modl
|
|
| 4485 | - when (not is_interpreted) $
|
|
| 4486 | - throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
|
|
| 4487 | - return modl
|
|
| 4857 | + modl <- lookupModuleName modname
|
|
| 4858 | + checkInterpretedModule modl
|
|
| 4859 | + |
|
| 4860 | +checkInterpretedModule :: GHC.GhcMonad m => Module -> m Module
|
|
| 4861 | +checkInterpretedModule modl = do
|
|
| 4862 | + let str = moduleNameString $ moduleName modl
|
|
| 4863 | + hug <- hsc_HUG <$> GHC.getSession
|
|
| 4864 | + unless (HUG.memberHugUnit (moduleUnit modl) hug) $
|
|
| 4865 | + throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
|
|
| 4866 | + is_interpreted <- GHC.moduleIsInterpreted modl
|
|
| 4867 | + when (not is_interpreted) $
|
|
| 4868 | + throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
|
|
| 4869 | + return modl
|
|
| 4488 | 4870 | |
| 4489 | 4871 | wantNameFromInterpretedModule :: GHC.GhcMonad m
|
| 4490 | 4872 | => (Name -> SDoc -> m ())
|
| ... | ... | @@ -465,7 +465,7 @@ instance DiagnosticCodeNameSpace GHCi where |
| 465 | 465 | |
| 466 | 466 | type GhciDiagnosticCode :: Symbol -> Nat
|
| 467 | 467 | type family GhciDiagnosticCode c = n | n -> c where
|
| 468 | - GhciDiagnosticCode "GhciCommandNotSupportedInMultiMode" = 83514
|
|
| 468 | + GhciDiagnosticCode "GhciCommandNotSupportedInMultiMode" = Outdated 83514
|
|
| 469 | 469 | GhciDiagnosticCode "GhciInvalidArgumentString" = 68894
|
| 470 | 470 | GhciDiagnosticCode "GhciCommandSyntaxError" = 72682
|
| 471 | 471 | GhciDiagnosticCode "GhciInvalidPromptString" = 50882
|
| ... | ... | @@ -113,7 +113,7 @@ srcSpanFilePath = unpackFS . srcSpanFile |
| 113 | 113 | -- | Try to find the location of the given identifier at the given
|
| 114 | 114 | -- position in the module.
|
| 115 | 115 | findLoc :: GhcMonad m
|
| 116 | - => Map ModuleName ModInfo
|
|
| 116 | + => Map Module ModInfo
|
|
| 117 | 117 | -> RealSrcSpan
|
| 118 | 118 | -> String
|
| 119 | 119 | -> ExceptT GhciModuleError m (ModInfo,Name,SrcSpan)
|
| ... | ... | @@ -133,7 +133,7 @@ findLoc infos span0 string = do |
| 133 | 133 | |
| 134 | 134 | -- | Find any uses of the given identifier in the codebase.
|
| 135 | 135 | findNameUses :: (GhcMonad m)
|
| 136 | - => Map ModuleName ModInfo
|
|
| 136 | + => Map Module ModInfo
|
|
| 137 | 137 | -> RealSrcSpan
|
| 138 | 138 | -> String
|
| 139 | 139 | -> ExceptT GhciModuleError m [SrcSpan]
|
| ... | ... | @@ -160,7 +160,7 @@ stripSurrounding xs = filter (not . isRedundant) xs |
| 160 | 160 | -- | Try to resolve the name located at the given position, or
|
| 161 | 161 | -- otherwise resolve based on the current module's scope.
|
| 162 | 162 | findName :: GhcMonad m
|
| 163 | - => Map ModuleName ModInfo
|
|
| 163 | + => Map Module ModInfo
|
|
| 164 | 164 | -> RealSrcSpan
|
| 165 | 165 | -> ModInfo
|
| 166 | 166 | -> String
|
| ... | ... | @@ -186,11 +186,11 @@ findName infos span0 mi string = |
| 186 | 186 | |
| 187 | 187 | -- | Try to resolve the name from another (loaded) module's exports.
|
| 188 | 188 | resolveNameFromModule :: GhcMonad m
|
| 189 | - => Map ModuleName ModInfo
|
|
| 189 | + => Map Module ModInfo
|
|
| 190 | 190 | -> Name
|
| 191 | 191 | -> ExceptT GhciModuleError m Name
|
| 192 | 192 | resolveNameFromModule infos name = do
|
| 193 | - info <- maybe (throwE $ GhciNoModuleForName name) pure (nameModule_maybe name >>= \modL -> M.lookup (moduleName modL) infos)
|
|
| 193 | + info <- maybe (throwE $ GhciNoModuleForName name) pure (nameModule_maybe name >>= \modL -> M.lookup modL infos)
|
|
| 194 | 194 | let all_names = modInfo_rdrs info
|
| 195 | 195 | maybe (throwE GhciNoMatchingModuleExport) pure $
|
| 196 | 196 | find (matchName name) all_names
|
| ... | ... | @@ -206,7 +206,7 @@ resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $ |
| 206 | 206 | |
| 207 | 207 | -- | Try to find the type of the given span.
|
| 208 | 208 | findType :: GhcMonad m
|
| 209 | - => Map ModuleName ModInfo
|
|
| 209 | + => Map Module ModInfo
|
|
| 210 | 210 | -> RealSrcSpan
|
| 211 | 211 | -> String
|
| 212 | 212 | -> ExceptT GhciModuleError m (ModInfo, Type)
|
| ... | ... | @@ -228,34 +228,36 @@ findType infos span0 string = do |
| 228 | 228 | |
| 229 | 229 | -- | Guess a module name from a file path.
|
| 230 | 230 | guessModule :: GhcMonad m
|
| 231 | - => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName
|
|
| 231 | + => Map Module ModInfo -> FilePath -> MaybeT m Module
|
|
| 232 | 232 | guessModule infos fp = do
|
| 233 | - target <- lift $ guessTarget fp Nothing Nothing
|
|
| 234 | - case targetId target of
|
|
| 235 | - TargetModule mn -> return mn
|
|
| 233 | + target <- lift $ guessTargetId fp
|
|
| 234 | + case target of
|
|
| 235 | + TargetModule mn -> MaybeT $ pure $ findModByModuleName mn
|
|
| 236 | 236 | TargetFile fp' _ -> guessModule' fp'
|
| 237 | 237 | where
|
| 238 | - guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName
|
|
| 238 | + guessModule' :: GhcMonad m => FilePath -> MaybeT m Module
|
|
| 239 | 239 | guessModule' fp' = case findModByFp fp' of
|
| 240 | 240 | Just mn -> return mn
|
| 241 | 241 | Nothing -> do
|
| 242 | 242 | fp'' <- liftIO (makeRelativeToCurrentDirectory fp')
|
| 243 | 243 | |
| 244 | - target' <- lift $ guessTarget fp'' Nothing Nothing
|
|
| 245 | - case targetId target' of
|
|
| 246 | - TargetModule mn -> return mn
|
|
| 244 | + target' <- lift $ guessTargetId fp''
|
|
| 245 | + case target' of
|
|
| 246 | + TargetModule mn -> MaybeT . pure $ findModByModuleName mn
|
|
| 247 | 247 | _ -> MaybeT . pure $ findModByFp fp''
|
| 248 | 248 | |
| 249 | - findModByFp :: FilePath -> Maybe ModuleName
|
|
| 249 | + findModByFp :: FilePath -> Maybe Module
|
|
| 250 | 250 | findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)
|
| 251 | 251 | where
|
| 252 | - mifp :: (ModuleName, ModInfo) -> Maybe FilePath
|
|
| 252 | + mifp :: (Module, ModInfo) -> Maybe FilePath
|
|
| 253 | 253 | mifp = ml_hs_file . ms_location . modinfoSummary . snd
|
| 254 | 254 | |
| 255 | + findModByModuleName :: ModuleName -> Maybe Module
|
|
| 256 | + findModByModuleName mn = find ((== mn) . moduleName) (M.keys infos)
|
|
| 255 | 257 | |
| 256 | 258 | -- | Collect type info data for the loaded modules.
|
| 257 | -collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]
|
|
| 258 | - -> m (Map ModuleName ModInfo)
|
|
| 259 | +collectInfo :: (GhcMonad m) => Map Module ModInfo -> [Module]
|
|
| 260 | + -> m (Map Module ModInfo)
|
|
| 259 | 261 | collectInfo ms loaded = do
|
| 260 | 262 | df <- getDynFlags
|
| 261 | 263 | unit_state <- hsc_units <$> getSession
|
| ... | ... | @@ -299,17 +301,17 @@ srcFilePath modSum = fromMaybe obj_fp src_fp |
| 299 | 301 | ms_loc = ms_location modSum
|
| 300 | 302 | |
| 301 | 303 | -- | Get info about the module: summary, types, etc.
|
| 302 | -getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo
|
|
| 303 | -getModInfo name = do
|
|
| 304 | - m <- getModSummary name
|
|
| 305 | - p <- parseModule m
|
|
| 304 | +getModInfo :: (GhcMonad m) => Module -> m ModInfo
|
|
| 305 | +getModInfo m = do
|
|
| 306 | + mod_summary <- getModSummary m
|
|
| 307 | + p <- parseModule mod_summary
|
|
| 306 | 308 | typechecked <- typecheckModule p
|
| 307 | 309 | let allTypes = processAllTypeCheckedModule typechecked
|
| 308 | 310 | let !rdr_env = tcg_rdr_env (fst $ tm_internals_ typechecked)
|
| 309 | - ts <- liftIO $ getModificationTime $ srcFilePath m
|
|
| 311 | + ts <- liftIO $ getModificationTime $ srcFilePath mod_summary
|
|
| 310 | 312 | return $
|
| 311 | 313 | ModInfo
|
| 312 | - { modinfoSummary = m
|
|
| 314 | + { modinfoSummary = mod_summary
|
|
| 313 | 315 | , modinfoSpans = allTypes
|
| 314 | 316 | , modinfoRdrEnv = forceGlobalRdrEnv rdr_env
|
| 315 | 317 | , modinfoLastUpdate = ts
|
| ... | ... | @@ -91,7 +91,6 @@ data GHCiState = GHCiState |
| 91 | 91 | prompt_cont :: PromptFunction,
|
| 92 | 92 | editor :: String,
|
| 93 | 93 | stop :: String,
|
| 94 | - multiMode :: Bool,
|
|
| 95 | 94 | localConfig :: LocalConfigBehaviour,
|
| 96 | 95 | options :: [GHCiOption],
|
| 97 | 96 | line_number :: !Int, -- ^ input line
|
| ... | ... | @@ -155,7 +154,7 @@ data GHCiState = GHCiState |
| 155 | 154 | long_help :: String,
|
| 156 | 155 | lastErrorLocations :: IORef [(FastString, Int)],
|
| 157 | 156 | |
| 158 | - mod_infos :: !(Map ModuleName ModInfo),
|
|
| 157 | + mod_infos :: !(Map Module ModInfo),
|
|
| 159 | 158 | |
| 160 | 159 | flushStdHandles :: ForeignHValue,
|
| 161 | 160 | -- ^ @hFlush stdout; hFlush stderr@ in the interpreter
|
| ... | ... | @@ -302,7 +302,8 @@ ghciUI units srcs maybe_expr = do |
| 302 | 302 | [] -> return []
|
| 303 | 303 | _ -> do
|
| 304 | 304 | s <- initMake srcs
|
| 305 | - return $ map (uncurry (,Nothing,)) s
|
|
| 305 | + dflags <- getDynFlags
|
|
| 306 | + return $ map (uncurry (,Just $ homeUnitId_ dflags,)) s
|
|
| 306 | 307 | interactiveUI defaultGhciSettings hs_srcs maybe_expr
|
| 307 | 308 | #endif
|
| 308 | 309 |
| ... | ... | @@ -6,39 +6,37 @@ ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2556:55: Note [Plan (AFTE |
| 6 | 6 | ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:2985:13: Note [Case binder next]
|
| 7 | 7 | ref compiler/GHC/Core/Opt/Simplify/Iteration.hs:4345:8: Note [Lambda-bound unfoldings]
|
| 8 | 8 | ref compiler/GHC/Core/Opt/Simplify/Utils.hs:1387:37: Note [Gentle mode]
|
| 9 | -ref compiler/GHC/Core/Opt/Specialise.hs:1761:29: Note [Arity decrease]
|
|
| 9 | +ref compiler/GHC/Core/Opt/Specialise.hs:1758:29: Note [Arity decrease]
|
|
| 10 | 10 | ref compiler/GHC/Core/TyCo/Rep.hs:1783:31: Note [What prevents a constraint from floating]
|
| 11 | -ref compiler/GHC/Driver/DynFlags.hs:1218:52: Note [Eta-reduction in -O0]
|
|
| 12 | -ref compiler/GHC/Driver/Main.hs:1901:34: Note [simpleTidyPgm - mkBootModDetailsTc]
|
|
| 11 | +ref compiler/GHC/Driver/DynFlags.hs:1217:52: Note [Eta-reduction in -O0]
|
|
| 12 | +ref compiler/GHC/Driver/Main.hs:1886:34: Note [simpleTidyPgm - mkBootModDetailsTc]
|
|
| 13 | 13 | ref compiler/GHC/Hs/Expr.hs:189:63: Note [Pending Splices]
|
| 14 | -ref compiler/GHC/Hs/Expr.hs:2194:87: Note [Lifecycle of a splice]
|
|
| 15 | -ref compiler/GHC/Hs/Expr.hs:2230:7: Note [Pending Splices]
|
|
| 16 | -ref compiler/GHC/Hs/Extension.hs:148:5: Note [Strict argument type constraints]
|
|
| 14 | +ref compiler/GHC/Hs/Expr.hs:2208:87: Note [Lifecycle of a splice]
|
|
| 15 | +ref compiler/GHC/Hs/Expr.hs:2244:7: Note [Pending Splices]
|
|
| 16 | +ref compiler/GHC/Hs/Extension.hs:151:5: Note [Strict argument type constraints]
|
|
| 17 | 17 | ref compiler/GHC/Hs/Pat.hs:151:74: Note [Lifecycle of a splice]
|
| 18 | 18 | ref compiler/GHC/HsToCore/Pmc/Solver.hs:860:20: Note [COMPLETE sets on data families]
|
| 19 | 19 | ref compiler/GHC/HsToCore/Quote.hs:1533:7: Note [How brackets and nested splices are handled]
|
| 20 | 20 | ref compiler/GHC/Stg/Unarise.hs:457:32: Note [Renaming during unarisation]
|
| 21 | 21 | ref compiler/GHC/Tc/Gen/HsType.hs:563:56: Note [Skolem escape prevention]
|
| 22 | -ref compiler/GHC/Tc/Gen/HsType.hs:2717:7: Note [Matching a kind signature with a declaration]
|
|
| 22 | +ref compiler/GHC/Tc/Gen/HsType.hs:2718:7: Note [Matching a kind signature with a declaration]
|
|
| 23 | 23 | ref compiler/GHC/Tc/Gen/Pat.hs:284:20: Note [Typing patterns in pattern bindings]
|
| 24 | -ref compiler/GHC/Tc/Gen/Pat.hs:1378:7: Note [Matching polytyped patterns]
|
|
| 24 | +ref compiler/GHC/Tc/Gen/Pat.hs:1380:7: Note [Matching polytyped patterns]
|
|
| 25 | 25 | ref compiler/GHC/Tc/Gen/Sig.hs:91:10: Note [Overview of type signatures]
|
| 26 | -ref compiler/GHC/Tc/Gen/Splice.hs:368:16: Note [How brackets and nested splices are handled]
|
|
| 27 | -ref compiler/GHC/Tc/Gen/Splice.hs:543:35: Note [PendingRnSplice]
|
|
| 28 | -ref compiler/GHC/Tc/Gen/Splice.hs:670:7: Note [How brackets and nested splices are handled]
|
|
| 26 | +ref compiler/GHC/Tc/Gen/Splice.hs:367:16: Note [How brackets and nested splices are handled]
|
|
| 27 | +ref compiler/GHC/Tc/Gen/Splice.hs:542:35: Note [PendingRnSplice]
|
|
| 28 | +ref compiler/GHC/Tc/Gen/Splice.hs:669:7: Note [How brackets and nested splices are handled]
|
|
| 29 | 29 | ref compiler/GHC/Tc/Gen/Splice.hs:909:11: Note [How brackets and nested splices are handled]
|
| 30 | 30 | ref compiler/GHC/Tc/Instance/Family.hs:458:35: Note [Constrained family instances]
|
| 31 | -ref compiler/GHC/Tc/Solver/Rewrite.hs:1015:7: Note [Stability of rewriting]
|
|
| 32 | -ref compiler/GHC/Tc/TyCl.hs:1322:6: Note [Unification variables need fresh Names]
|
|
| 31 | +ref compiler/GHC/Tc/Solver/Rewrite.hs:1020:7: Note [Stability of rewriting]
|
|
| 32 | +ref compiler/GHC/Tc/TyCl.hs:1662:6: Note [Unification variables need fresh Names]
|
|
| 33 | 33 | ref compiler/GHC/Tc/Types/Constraint.hs:209:9: Note [NonCanonical Semantics]
|
| 34 | 34 | ref compiler/GHC/Types/Demand.hs:304:25: Note [Preserving Boxity of results is rarely a win]
|
| 35 | -ref compiler/GHC/Unit/Module/Deps.hs:86:13: Note [Structure of dep_boot_mods]
|
|
| 35 | +ref compiler/GHC/Unit/Module/Deps.hs:97:13: Note [Structure of dep_boot_mods]
|
|
| 36 | 36 | ref compiler/GHC/Utils/Monad.hs:415:34: Note [multiShotIO]
|
| 37 | 37 | ref compiler/Language/Haskell/Syntax/Binds.hs:206:31: Note [fun_id in Match]
|
| 38 | 38 | ref configure.ac:205:10: Note [Linking ghc-bin against threaded stage0 RTS]
|
| 39 | 39 | ref docs/core-spec/core-spec.mng:177:6: Note [TyBinders]
|
| 40 | -ref ghc/GHCi/UI.hs:3292:17: Note [Multiple Home Units aware GHCi]
|
|
| 41 | -ref ghc/GHCi/UI.hs:3292:17: Note [Relation between the InteractiveContext and 'interactiveGhciUnitId']
|
|
| 42 | 40 | ref hadrian/src/Expression.hs:145:30: Note [Linking ghc-bin against threaded stage0 RTS]
|
| 43 | 41 | ref linters/lint-notes/Notes.hs:32:29: Note [" <> T.unpack x <> "]
|
| 44 | 42 | ref linters/lint-notes/Notes.hs:69:22: Note [...]
|