Hannes Siebenhandl pushed to branch wip/fendor/ghci-multiple-home-units at Glasgow Haskell Compiler / GHC

Commits:

20 changed files:

Changes:

  • compiler/GHC.hs
    ... ... @@ -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
    

  • compiler/GHC/Driver/Downsweep.hs
    ... ... @@ -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)
    

  • compiler/GHC/Driver/Session.hs
    ... ... @@ -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
     
    

  • compiler/GHC/Iface/Load.hs
    ... ... @@ -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
    

  • compiler/GHC/Rename/Unbound.hs
    ... ... @@ -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
    

  • compiler/GHC/Runtime/Context.hs
    ... ... @@ -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.
    

  • compiler/GHC/Runtime/Eval.hs
    ... ... @@ -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)
    

  • compiler/GHC/StgToByteCode.hs
    ... ... @@ -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
    

  • compiler/GHC/StgToJS/Linker/Linker.hs
    ... ... @@ -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
     
    

  • compiler/GHC/Tc/Module.hs
    ... ... @@ -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
     
    

  • compiler/GHC/Types/Name/Ppr.hs
    ... ... @@ -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
    

  • compiler/GHC/Unit/Env.hs
    ... ... @@ -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)))
    

  • compiler/GHC/Unit/Home/Graph.hs
    ... ... @@ -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
     --------------------------------------------------------------------------------
    

  • compiler/GHC/Unit/Types.hs
    ... ... @@ -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
    

  • ghc/GHCi/UI.hs
    ... ... @@ -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 ())
    

  • ghc/GHCi/UI/Exception.hs
    ... ... @@ -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
    

  • ghc/GHCi/UI/Info.hs
    ... ... @@ -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
    

  • ghc/GHCi/UI/Monad.hs
    ... ... @@ -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
    

  • ghc/Main.hs
    ... ... @@ -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
     
    

  • testsuite/tests/linters/notes.stdout
    ... ... @@ -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 [...]