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 [...]
|