Hannes Siebenhandl pushed to branch wip/fendor/no-load at Glasgow Haskell Compiler / GHC

Commits:

17 changed files:

Changes:

  • compiler/GHC/Driver/DynFlags.hs
    ... ... @@ -422,6 +422,8 @@ data DynFlags = DynFlags {
    422 422
    423 423 
       -- | GHCi scripts specified by -ghci-script, in reverse order
    424 424 
       ghciScripts           :: [String],
    425 
    +  -- | Instruct GHCi to not load the targets immediately
    426 
    +  ghciDontLoad          :: Bool,
    425 427
    426 428 
       -- Output style options
    427 429 
       pprUserLength         :: Int,
    ... ... @@ -677,6 +679,7 @@ defaultDynFlags mySettings =
    677 679 
             customWarningCategories = completeWarningCategorySet,
    678 680 
             fatalCustomWarningCategories = emptyWarningCategorySet,
    679 681 
             ghciScripts = [],
    682 
    +        ghciDontLoad = False,
    680 683 
             language = Nothing,
    681 684 
             safeHaskell = Sf_None,
    682 685 
             safeInfer   = True,

  • compiler/GHC/Driver/Make.hs
    ... ... @@ -135,6 +135,7 @@ import qualified GHC.Data.Maybe as M
    135 135 
     import GHC.Data.Graph.Directed.Reachability
    136 136 
     import qualified GHC.Unit.Home.Graph as HUG
    137 137 
     import GHC.Unit.Home.PackageTable
    138 
    +import qualified Data.List as List
    138 139
    139 140 
     -- -----------------------------------------------------------------------------
    140 141 
     -- Loading the program
    ... ... @@ -343,8 +344,9 @@ warnUnknownModules hsc_env dflags mod_graph = do
    343 344 
     data LoadHowMuch
    344 345 
        = LoadAllTargets
    345 346 
          -- ^ Load all targets and its dependencies.
    346 
    -   | LoadUpTo HomeUnitModule
    347 
    +   | LoadUpTo [HomeUnitModule]
    347 348 
          -- ^ Load only the given module and its dependencies.
    349 
    +     -- If empty, we load none of the targets
    348 350 
        | LoadDependenciesOf HomeUnitModule
    349 351 
          -- ^ Load only the dependencies of the given module, but not the module
    350 352 
          -- itself.
    ... ... @@ -517,16 +519,16 @@ countMods (ResolvedCycle ns) = length ns
    517 519 
     countMods (UnresolvedCycle ns) = length ns
    518 520
    519 521 
     -- See Note [Upsweep] for a high-level description.
    520 
    -createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]
    522 
    +createBuildPlan :: ModuleGraph -> Maybe [HomeUnitModule] -> [BuildPlan]
    521 523 
     createBuildPlan mod_graph maybe_top_mod =
    522 524 
         let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles
    523 
    -        cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod
    524 
    -
    525 
    +        cycle_mod_graph                 = topSortModuleGraph True  mod_graph maybe_top_mod
    526 
    +        cycle_mod_graph_with_boot_nodes = topSortModuleGraph False mod_graph maybe_top_mod
    525 527 
             -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles.
    526 528 
             build_plan :: [BuildPlan]
    527 529 
             build_plan
    528 530 
               -- Fast path, if there are no boot modules just do a normal toposort
    529 
    -          | isEmptyModuleEnv boot_modules = collapseAcyclic $ topSortModuleGraph False mod_graph maybe_top_mod
    531 
    +          | isEmptyModuleEnv boot_modules = collapseAcyclic cycle_mod_graph_with_boot_nodes
    530 532 
               | otherwise = toBuildPlan cycle_mod_graph []
    531 533
    532 534 
             toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
    ... ... @@ -599,13 +601,18 @@ createBuildPlan mod_graph maybe_top_mod =
    599 601
    600 602 
             topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing
    601 603
    604 
    +        modGraphSize
    605 
    +          | isEmptyModuleEnv boot_modules = lengthMGWithSCC cycle_mod_graph_with_boot_nodes
    606 
    +          | otherwise                     = lengthMGWithSCC cycle_mod_graph
    602 607
    603 608 
       in
    604 
    -
    605 
    -    assertPpr (sum (map countMods build_plan) == lengthMG mod_graph)
    606 
    -              (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (lengthMG mod_graph))])
    609 
    +    -- The assertion needs to operate on 'cycle_mod_graph' as we prune the module graph during 'topSortModuleGraph'.
    610 
    +    assertPpr (sum (map countMods build_plan) == modGraphSize)
    611 
    +              (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr modGraphSize)])
    607 612 
                   build_plan
    608 
    -
    613 
    +  where
    614 
    +    lengthMGWithSCC :: [SCC a] -> Int
    615 
    +    lengthMGWithSCC = List.foldl' (\acc scc -> length scc + acc) 0
    609 616
    610 617 
     -- | Generalized version of 'load' which also supports a custom
    611 618 
     -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
    ... ... @@ -640,16 +647,20 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do
    640 647
    641 648 
         -- check that the module given in HowMuch actually exists, otherwise
    642 649 
         -- topSortModuleGraph will bomb later.
    643 
    -    let checkHowMuch (LoadUpTo m)           = checkMod m
    644 
    -        checkHowMuch (LoadDependenciesOf m) = checkMod m
    650 
    +    let checkHowMuch (LoadUpTo ms)          = checkMods ms
    651 
    +        checkHowMuch (LoadDependenciesOf m) = checkMods [m]
    645 652 
             checkHowMuch _ = id
    646 653
    647 
    -        checkMod m and_then
    648 
    -            | m `Set.member` all_home_mods = and_then
    649 
    -            | otherwise = do
    650 
    -                    throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan
    651 
    -                                  $ GhcDriverMessage
    652 
    -                                  $ DriverModuleNotFound (moduleUnit m) (moduleName m)
    654 
    +        checkMods ms and_then =
    655 
    +          case List.partition (`Set.member` all_home_mods) ms of
    656 
    +            (_, []) -> and_then
    657 
    +            (_, not_found_mods) -> do
    658 
    +              let
    659 
    +                mkModuleNotFoundError m =
    660 
    +                  mkPlainErrorMsgEnvelope noSrcSpan
    661 
    +                  $ GhcDriverMessage
    662 
    +                  $ DriverModuleNotFound (moduleUnit m) (moduleName m)
    663 
    +              throwErrors $ mkMessages $ listToBag [mkModuleNotFoundError not_found | not_found <- not_found_mods]
    653 664
    654 665 
         checkHowMuch how_much $ do
    655 666
    ... ... @@ -662,12 +673,12 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do
    662 673 
         -- are definitely unnecessary, then emit a warning.
    663 674 
         warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps)
    664 675
    665 
    -    let maybe_top_mod = case how_much of
    676 
    +    let maybe_top_mods = case how_much of
    666 677 
                               LoadUpTo m           -> Just m
    667 
    -                          LoadDependenciesOf m -> Just m
    678 
    +                          LoadDependenciesOf m -> Just [m]
    668 679 
                               _                    -> Nothing
    669 680
    670 
    -        build_plan = createBuildPlan mod_graph maybe_top_mod
    681 
    +        build_plan = createBuildPlan mod_graph maybe_top_mods
    671 682
    672 683
    673 684 
         cache <- liftIO $ maybe (return []) iface_clearCache mhmi_cache
    ... ... @@ -1301,7 +1312,7 @@ topSortModuleGraph
    1301 1312 
               :: Bool
    1302 1313 
               -- ^ Drop hi-boot nodes? (see below)
    1303 1314 
               -> ModuleGraph
    1304 
    -          -> Maybe HomeUnitModule
    1315 
    +          -> Maybe [HomeUnitModule]
    1305 1316 
                  -- ^ Root module name.  If @Nothing@, use the full graph.
    1306 1317 
               -> [SCC ModuleGraphNode]
    1307 1318 
     -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
    ... ... @@ -1351,7 +1362,7 @@ topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod =
    1351 1362 
         cmpModuleGraphNodes k1 k2 = compare (moduleGraphNodeRank k1) (moduleGraphNodeRank k2)
    1352 1363 
                                       `mappend` compare k2 k1
    1353 1364
    1354 
    -topSortModules :: Bool -> [ModuleGraphNode] -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
    1365 
    +topSortModules :: Bool -> [ModuleGraphNode] -> Maybe [HomeUnitModule] -> [SCC ModuleGraphNode]
    1355 1366 
     topSortModules drop_hs_boot_nodes summaries mb_root_mod
    1356 1367 
       = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
    1357 1368 
       where
    ... ... @@ -1360,17 +1371,20 @@ topSortModules drop_hs_boot_nodes summaries mb_root_mod
    1360 1371
    1361 1372 
         initial_graph = case mb_root_mod of
    1362 1373 
             Nothing -> graph
    1363 
    -        Just (Module uid root_mod) ->
    1374 
    +        Just mods ->
    1364 1375 
                 -- restrict the graph to just those modules reachable from
    1365 1376 
                 -- the specified module.  We do this by building a graph with
    1366 1377 
                 -- the full set of nodes, and determining the reachable set from
    1367 1378 
                 -- the specified node.
    1368 
    -            let root | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid
    1369 
    -                     , graph `hasVertexG` node
    1370 
    -                     = node
    1371 
    -                     | otherwise
    1372 
    -                     = throwGhcException (ProgramError "module does not exist")
    1373 
    -            in graphFromEdgedVerticesUniq (seq root (root:allReachable (graphReachability graph) root))
    1379 
    +            let
    1380 
    +              findNodeForModule (Module uid root_mod)
    1381 
    +                | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid
    1382 
    +                , graph `hasVertexG` node
    1383 
    +                = seq node node
    1384 
    +                | otherwise
    1385 
    +                = throwGhcException (ProgramError "module does not exist")
    1386 
    +              roots = fmap findNodeForModule mods
    1387 
    +            in graphFromEdgedVerticesUniq (seq roots (roots ++ allReachableMany (graphReachability graph) roots))
    1374 1388
    1375 1389 
     newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a }
    1376 1390 
       deriving (Functor, Traversable, Foldable)

  • compiler/GHC/Driver/Session.hs
    ... ... @@ -764,6 +764,9 @@ addHaddockOpts f d = d { haddockOptions = Just f}
    764 764
    765 765 
     addGhciScript f d = d { ghciScripts = f : ghciScripts d}
    766 766
    767 
    +setDontLoadGhci :: Bool -> DynP ()
    768 
    +setDontLoadGhci f = upd $ \d -> d { ghciDontLoad = f }
    769 
    +
    767 770 
     setInteractivePrint f d = d { interactivePrint = Just f}
    768 771
    769 772 
     -----------------------------------------------------------------------------
    ... ... @@ -1344,6 +1347,8 @@ dynamic_flags_deps = [
    1344 1347 
       , make_ord_flag defGhcFlag "haddock-opts"         (hasArg addHaddockOpts)
    1345 1348 
       , make_ord_flag defGhcFlag "hpcdir"               (SepArg setOptHpcDir)
    1346 1349 
       , make_ord_flag defGhciFlag "ghci-script"         (hasArg addGhciScript)
    1350 
    +  , make_ord_flag defGhciFlag "ghci-no-load"        (NoArg (setDontLoadGhci True))
    1351 
    +  , make_ord_flag defGhciFlag "ghci-load"           (NoArg (setDontLoadGhci False))
    1347 1352 
       , make_ord_flag defGhciFlag "interactive-print"   (hasArg setInteractivePrint)
    1348 1353 
       , make_ord_flag defGhcFlag "ticky-allocd"
    1349 1354 
             (NoArg (setGeneralFlag Opt_Ticky_Allocd))

  • compiler/GHC/Unit/Module/Graph.hs
    ... ... @@ -67,6 +67,7 @@ module GHC.Unit.Module.Graph
    67 67 
        , mapMG, mgMapM
    68 68 
        , mgModSummaries
    69 69 
        , mgLookupModule
    70 
    +   , mgLookupModuleName
    70 71 
        , mgHasHoles
    71 72 
        , showModMsg
    72 73
    ... ... @@ -523,6 +524,17 @@ mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss
    523 524 
           = Just ms
    524 525 
         go _ = Nothing
    525 526
    527 
    +-- |
    528 
    +-- TODO @fendor: Docs
    529 
    +mgLookupModuleName :: ModuleGraph -> ModuleName -> [ModuleNodeInfo]
    530 
    +mgLookupModuleName ModuleGraph{..} m = mapMaybe go mg_mss
    531 
    +  where
    532 
    +    go (ModuleNode _ ms)
    533 
    +      | NotBoot <- isBootModuleNodeInfo ms
    534 
    +      , moduleName (moduleNodeInfoModule ms) == m
    535 
    +      = Just ms
    536 
    +    go _ = Nothing
    537 
    +
    526 538 
     mgMember :: ModuleGraph -> NodeKey -> Bool
    527 539 
     mgMember graph k = isJust $ snd (mg_graph graph) k
    528 540

  • ghc/GHCi/UI.hs
    ... ... @@ -948,7 +948,7 @@ runGHCi paths maybe_exprs = do
    948 948 
       -- immediately rather than going on to evaluate the expression.
    949 949 
       when (not (null paths)) $ do
    950 950 
          ok <- ghciHandle (\e -> do showException e; return Failed) $
    951 
    -                    loadModule paths
    951 
    +                    initialLoadModule paths
    952 952 
          when (isJust maybe_exprs && failed ok) $
    953 953 
             liftIO (exitWith (ExitFailure 1))
    954 954
    ... ... @@ -1302,7 +1302,8 @@ runOneCommand eh gCmd = do
    1302 1302 
           st <- getGHCiState
    1303 1303 
           ghciHandle (\e -> lift $ eh e >>= return . Just) $
    1304 1304 
             handleSourceError printErrorAndFail $
    1305 
    -          cmd_wrapper st $ doCommand c
    1305 
    +          handleGhciCommandError printErrorAndContinue $
    1306 
    +            cmd_wrapper st $ doCommand c
    1306 1307 
                    -- source error's are handled by runStmt
    1307 1308 
                    -- is the handler necessary here?
    1308 1309 
       where
    ... ... @@ -1310,6 +1311,10 @@ runOneCommand eh gCmd = do
    1310 1311 
             printGhciException err
    1311 1312 
             return $ Just False     -- Exit ghc -e, but not GHCi
    1312 1313
    1314 
    +    printErrorAndContinue err = do
    1315 
    +        printGhciCommandException err
    1316 
    +        return $ Just False     -- Exit ghc -e, but not GHCi
    1317 
    +
    1313 1318 
         noSpace q = q >>= maybe (return Nothing)
    1314 1319 
                                 (\c -> case removeSpaces c of
    1315 1320 
                                          ""   -> noSpace q
    ... ... @@ -2196,6 +2201,11 @@ loadModule fs = do
    2196 2201 
       (_, result) <- runAndPrintStats (const Nothing) (loadModule' fs)
    2197 2202 
       either (liftIO . Exception.throwIO) return result
    2198 2203
    2204 
    +initialLoadModule :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag
    2205 
    +initialLoadModule fs = do
    2206 
    +  (_, result) <- runAndPrintStats (const Nothing) (initialLoadModule' fs)
    2207 
    +  either (liftIO . Exception.throwIO) return result
    2208 
    +
    2199 2209 
     -- | @:load@ command
    2200 2210 
     loadModule_ :: GhciMonad m => [FilePath] -> m ()
    2201 2211 
     loadModule_ fs = void $ loadModule (zip3 fs (repeat (Just interactiveSessionUnitId)) (repeat Nothing))
    ... ... @@ -2203,6 +2213,44 @@ loadModule_ fs = void $ loadModule (zip3 fs (repeat (Just interactiveSessionUnit
    2203 2213 
     loadModuleDefer :: GhciMonad m => [FilePath] -> m ()
    2204 2214 
     loadModuleDefer = wrapDeferTypeErrors . loadModule_
    2205 2215
    2216 
    +initialLoadModule' :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag
    2217 
    +initialLoadModule' files = do
    2218 
    +  let (filenames, uids, phases) = unzip3 files
    2219 
    +  exp_filenames <- mapM expandPath filenames
    2220 
    +  let files' = zip3 exp_filenames uids phases
    2221 
    +  targets <- mapM (\(file, uid, phase) -> GHC.guessTarget file uid phase) files'
    2222 
    +
    2223 
    +  -- NOTE: we used to do the dependency anal first, so that if it
    2224 
    +  -- fails we didn't throw away the current set of modules.  This would
    2225 
    +  -- require some re-working of the GHC interface, so we'll leave it
    2226 
    +  -- as a ToDo for now.
    2227 
    +
    2228 
    +  hsc_env <- GHC.getSession
    2229 
    +  let !dflags = hsc_dflags hsc_env
    2230 
    +
    2231 
    +  let load_module = do
    2232 
    +        -- unload first
    2233 
    +        _ <- GHC.abandonAll
    2234 
    +        clearCaches
    2235 
    +
    2236 
    +        GHC.setTargets targets
    2237 
    +        if ghciDontLoad dflags
    2238 
    +          then
    2239 
    +            doLoadAndCollectInfo Load (LoadUpTo [])
    2240 
    +          else
    2241 
    +            doLoadAndCollectInfo Load LoadAllTargets
    2242 
    +
    2243 
    +  if gopt Opt_GhciLeakCheck dflags
    2244 
    +    then do
    2245 
    +      -- Grab references to the currently loaded modules so that we can see if
    2246 
    +      -- they leak.
    2247 
    +      leak_indicators <- liftIO $ getLeakIndicators hsc_env
    2248 
    +      success <- load_module
    2249 
    +      liftIO $ checkLeakIndicators dflags leak_indicators
    2250 
    +      return success
    2251 
    +    else
    2252 
    +      load_module
    2253 
    +
    2206 2254 
     loadModule' :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag
    2207 2255 
     loadModule' files = do
    2208 2256 
       let (filenames, uids, phases) = unzip3 files
    ... ... @@ -2286,13 +2334,18 @@ unAddModule files = do
    2286 2334 
     -- | @:reload@ command
    2287 2335 
     reloadModule :: GhciMonad m => String -> m ()
    2288 2336 
     reloadModule m = do
    2289 
    -  session <- GHC.getSession
    2290 
    -  let home_unit = homeUnitId (hsc_home_unit session)
    2291 
    -  ok <- doLoadAndCollectInfo Reload (loadTargets home_unit)
    2337 
    +  let mods = words m
    2338 
    +  loadTarget <- findLoadTargets mods
    2339 
    +  ok <- doLoadAndCollectInfo Reload loadTarget
    2292 2340 
       when (failed ok) failIfExprEvalMode
    2293 2341 
       where
    2294 
    -    loadTargets hu | null m    = LoadAllTargets
    2295 
    -                   | otherwise = LoadUpTo (mkModule hu (GHC.mkModuleName m))
    2342 
    +    findLoadTargets modls
    2343 
    +      | null modls =
    2344 
    +          pure LoadAllTargets
    2345 
    +      | otherwise = do
    2346 
    +          mod_graph <- GHC.getModuleGraph
    2347 
    +          let mods = concatMap (fmap (fmap toUnitId . GHC.moduleNodeInfoModule) . GHC.mgLookupModuleName mod_graph) [GHC.mkModuleName modl | modl <- modls]
    2348 
    +          pure $ LoadUpTo mods
    2296 2349
    2297 2350 
     reloadModuleDefer :: GhciMonad m => String -> m ()
    2298 2351 
     reloadModuleDefer = wrapDeferTypeErrors . reloadModule
    ... ... @@ -4747,8 +4800,11 @@ showException se =
    4747 4800 
                Just other_ghc_ex        -> putException (show other_ghc_ex)
    4748 4801 
                Nothing                  ->
    4749 4802 
                    case fromException se of
    4750 
    -               Just UserInterrupt -> putException "Interrupted."
    4751 
    -               _                  -> putException ("*** Exception: " ++ show se)
    4803 
    +                Just (GhciCommandError s) -> putException (show (GhciCommandError s))
    4804 
    +                Nothing ->
    4805 
    +                  case fromException se of
    4806 
    +                  Just UserInterrupt -> putException "Interrupted."
    4807 
    +                  _                  -> putException ("*** Exception: " ++ show se)
    4752 4808 
       where
    4753 4809 
         putException = hPutStrLn stderr
    4754 4810
    ... ... @@ -4798,15 +4854,22 @@ lookupModuleName mName = lookupQualifiedModuleName NoPkgQual mName
    4798 4854 
     lookupQualifiedModuleName :: GHC.GhcMonad m => PkgQual -> ModuleName -> m Module
    4799 4855 
     lookupQualifiedModuleName qual modl = do
    4800 4856 
       GHC.lookupAllQualifiedModuleNames qual modl >>= \case
    4801 
    -    [] -> throwGhcException (CmdLineError ("module '" ++ str ++ "' could not be found."))
    4857 
    +    [] -> throwGhciCommandError (GhciModuleError $ GhciModuleNameNotFound modl)
    4802 4858 
         [m] -> pure m
    4803 
    -    ms -> throwGhcException (CmdLineError ("module name '" ++ str ++ "' is ambiguous:\n" ++ errorMsg ms))
    4859 
    +    ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl ms)
    4860 
    +
    4861 
    +lookupHomeUnitModuleName :: GHC.GhcMonad m => ModuleName -> m HomeUnitModule
    4862 
    +lookupHomeUnitModuleName modl = do
    4863 
    +  m <- GHC.lookupLoadedHomeModuleByModuleName modl >>= \case
    4864 
    +    Nothing -> throwGhciCommandError (GhciModuleError $ GhciNoLocalModuleName modl)
    4865 
    +    Just [m] -> pure m
    4866 
    +    Just ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl ms)
    4867 
    +
    4868 
    +  if unitIsDefinite (moduleUnit m)
    4869 
    +    then pure (fmap toUnitId m)
    4870 
    +    else throwGhcException (CmdLineError ("module '" ++ str ++ "' is not from a definite unit"))
    4804 4871 
       where
    4805 4872 
         str = moduleNameString modl
    4806 
    -    errorMsg ms = intercalate "\n"
    4807 
    -      [ "- " ++ unitIdString (toUnitId (moduleUnit m)) ++ ":" ++ moduleNameString (moduleName m)
    4808 
    -      | m <- ms
    4809 
    -      ]
    4810 4873
    4811 4874 
     showModule :: Module -> String
    4812 4875 
     showModule = moduleNameString . moduleName

  • ghc/GHCi/UI/Exception.hs
    ... ... @@ -5,7 +5,10 @@
    5 5 
     {-# LANGUAGE UndecidableInstances #-}
    6 6 
     {-# LANGUAGE LambdaCase #-}
    7 7 
     module GHCi.UI.Exception
    8 
    -  ( GhciMessage(..)
    8 
    +  ( GhciCommandError(..)
    9 
    +  , throwGhciCommandError
    10 
    +  , handleGhciCommandError
    11 
    +  , GhciMessage(..)
    9 12 
       , GhciMessageOpts(..)
    10 13 
       , fromGhcOpts
    11 14 
       , toGhcHint
    ... ... @@ -29,19 +32,57 @@ import GHC.Tc.Errors.Ppr
    29 32 
     import GHC.Tc.Errors.Types
    30 33
    31 34 
     import GHC.Types.Error.Codes
    35 
    +import GHC.Types.SrcLoc (interactiveSrcSpan)
    32 36 
     import GHC.TypeLits
    33 37
    34 38 
     import GHC.Unit.State
    35 39
    36 40 
     import GHC.Utils.Outputable
    41 
    +import GHC.Utils.Error
    37 42
    38 43 
     import GHC.Generics
    39 44 
     import GHC.Types.Error
    40 45 
     import GHC.Types
    41 46 
     import qualified GHC
    42 47
    48 
    +import Control.Exception
    49 
    +import Control.Monad.Catch as MC (MonadCatch, catch)
    50 
    +import Control.Monad.IO.Class
    43 51 
     import Data.List.NonEmpty (NonEmpty(..))
    44 52
    53 
    +-- | A 'GhciCommandError' are messages that caused the abortion of a GHCi command.
    54 
    +newtype GhciCommandError =  GhciCommandError (Messages GhciMessage)
    55 
    +
    56 
    +instance Exception GhciCommandError
    57 
    +
    58 
    +instance Show GhciCommandError where
    59 
    +  -- We implement 'Show' because it's required by the 'Exception' instance, but diagnostics
    60 
    +  -- shouldn't be shown via the 'Show' typeclass, but rather rendered using the ppr functions.
    61 
    +  -- This also explains why there is no 'Show' instance for a 'MsgEnvelope'.
    62 
    +  show (GhciCommandError msgs) =
    63 
    +      renderWithContext defaultSDocContext
    64 
    +    . vcat
    65 
    +    . pprMsgEnvelopeBagWithLocDefault
    66 
    +    . getMessages
    67 
    +    $ msgs
    68 
    +
    69 
    +-- | Perform the given action and call the exception handler if the action
    70 
    +-- throws a 'SourceError'.  See 'SourceError' for more information.
    71 
    +handleGhciCommandError :: (MonadCatch m) =>
    72 
    +                     (GhciCommandError -> m a) -- ^ exception handler
    73 
    +                  -> m a -- ^ action to perform
    74 
    +                  -> m a
    75 
    +handleGhciCommandError handler act =
    76 
    +  MC.catch act (\(e :: GhciCommandError) -> handler e)
    77 
    +
    78 
    +throwGhciCommandError :: MonadIO m => GhciCommandMessage -> m a
    79 
    +throwGhciCommandError errorMessage =
    80 
    +  liftIO
    81 
    +    . throwIO
    82 
    +    . GhciCommandError
    83 
    +    . singleMessage
    84 
    +    $ mkPlainErrorMsgEnvelope interactiveSrcSpan (GhciCommandMessage errorMessage)
    85 
    +
    45 86 
     -- | The Options passed to 'diagnosticMessage'
    46 87 
     -- in the 'Diagnostic' instance of 'GhciMessage'.
    47 88 
     data GhciMessageOpts = GhciMessageOpts
    ... ... @@ -257,6 +298,9 @@ data GhciModuleError
    257 298 
       | GhciNoResolvedModules
    258 299 
       | GhciNoModuleForName GHC.Name
    259 300 
       | GhciNoMatchingModuleExport
    301 
    +  | GhciNoLocalModuleName !GHC.ModuleName
    302 
    +  | GhciModuleNameNotFound !GHC.ModuleName
    303 
    +  | GhciAmbiguousModuleName !GHC.ModuleName ![GHC.Module]
    260 304 
       deriving Generic
    261 305
    262 306 
     instance Diagnostic GhciModuleError where
    ... ... @@ -278,6 +322,16 @@ instance Diagnostic GhciModuleError where
    278 322 
           -> "No module for" <+> ppr name
    279 323 
         GhciNoMatchingModuleExport
    280 324 
           -> "No matching export in any local modules."
    325 
    +    GhciNoLocalModuleName modl
    326 
    +      -> "Module" <+> quotes (ppr modl) <+> "cannot be found locally"
    327 
    +    GhciModuleNameNotFound modl
    328 
    +      -> "module" <+> quotes (ppr modl) <+> "could not be found."
    329 
    +    GhciAmbiguousModuleName modl candidates
    330 
    +      -> "Module name" <+> quotes (ppr modl) <+> "is ambiguous" $+$
    331 
    +        vcat
    332 
    +          [ text "-" <+> ppr (GHC.moduleName m) <> colon <> ppr (GHC.moduleUnit m)
    333 
    +          | m <- candidates
    334 
    +          ]
    281 335
    282 336 
       diagnosticReason = \case
    283 337 
         GhciModuleNotFound{} ->
    ... ... @@ -294,6 +348,12 @@ instance Diagnostic GhciModuleError where
    294 348 
           ErrorWithoutFlag
    295 349 
         GhciNoMatchingModuleExport{} ->
    296 350 
           ErrorWithoutFlag
    351 
    +    GhciNoLocalModuleName{} ->
    352 
    +      ErrorWithoutFlag
    353 
    +    GhciModuleNameNotFound{} ->
    354 
    +      ErrorWithoutFlag
    355 
    +    GhciAmbiguousModuleName{} ->
    356 
    +      ErrorWithoutFlag
    297 357
    298 358 
       diagnosticHints = \case
    299 359 
         GhciModuleNotFound{} ->
    ... ... @@ -310,7 +370,12 @@ instance Diagnostic GhciModuleError where
    310 370 
           []
    311 371 
         GhciNoMatchingModuleExport{} ->
    312 372 
           []
    313 
    -
    373 
    +    GhciNoLocalModuleName{} ->
    374 
    +      []
    375 
    +    GhciModuleNameNotFound{} ->
    376 
    +      []
    377 
    +    GhciAmbiguousModuleName{} ->
    378 
    +      []
    314 379 
       diagnosticCode = constructorCode @GHCi
    315 380
    316 381 
     -- | A Diagnostic emitted by GHCi while executing a command
    ... ... @@ -487,6 +552,9 @@ type family GhciDiagnosticCode c = n | n -> c where
    487 552 
       GhciDiagnosticCode "GhciNoModuleForName"                = 21847
    488 553 
       GhciDiagnosticCode "GhciNoMatchingModuleExport"         = 59723
    489 554 
       GhciDiagnosticCode "GhciArgumentParseError"             = 35671
    555 
    +  GhciDiagnosticCode "GhciNoLocalModuleName"              = 81235
    556 
    +  GhciDiagnosticCode "GhciModuleNameNotFound"             = 40475
    557 
    +  GhciDiagnosticCode "GhciAmbiguousModuleName"            = 59019
    490 558
    491 559 
     type GhciConRecursInto :: Symbol -> Maybe Type
    492 560 
     type family GhciConRecursInto con where

  • ghc/GHCi/UI/Print.hs
    ... ... @@ -5,6 +5,7 @@ module GHCi.UI.Print
    5 5 
       , printForUserPartWay
    6 6 
       , printError
    7 7 
       , printGhciException
    8 
    +  , printGhciCommandException
    8 9 
       ) where
    9 10
    10 11 
     import qualified GHC
    ... ... @@ -64,7 +65,7 @@ printForUserPartWay doc = do
    64 65 
     -- | pretty-print a 'GhciCommandMessage'
    65 66 
     printError :: GhcMonad m => GhciCommandMessage -> m ()
    66 67 
     printError err =
    67 
    -  let errEnvelope = mkPlainErrorMsgEnvelope (UnhelpfulSpan UnhelpfulInteractive) err
    68 
    +  let errEnvelope = mkPlainErrorMsgEnvelope interactiveSrcSpan err
    68 69 
       in  printError' (const NoDiagnosticOpts) (singleMessage errEnvelope)
    69 70
    70 71 
     -- | Print the all diagnostics in a 'SourceError'.  Specialised for GHCi error reporting
    ... ... @@ -72,6 +73,9 @@ printError err =
    72 73 
     printGhciException :: GhcMonad m => SourceError -> m ()
    73 74 
     printGhciException err = printError' initGhciPrintConfig (GhciGhcMessage <$> (srcErrorMessages err))
    74 75
    76 
    +printGhciCommandException :: GhcMonad m => GhciCommandError -> m ()
    77 
    +printGhciCommandException (GhciCommandError errs) = printError' initGhciPrintConfig errs
    78 
    +
    75 79 
     printError' :: (GhcMonad m, Diagnostic a) => (DynFlags -> DiagnosticOpts a) -> Messages a -> m ()
    76 80 
     printError' get_config err = do
    77 81 
       dflags <- getDynFlags

  • testsuite/tests/ghc-e/should_fail/T18441fail5.stderr
    1 
    -<no location info>: error: [GHC-82272]
    2 
    -    module ‘Abcde’ cannot be found locally
    1 
    +<interactive>: error: [GHCi-81235]
    2 
    +    Module ‘Abcde’ cannot be found locally
    3 3
    4 4 
     1

  • testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr
    1 
    -module name 'Foo' is ambiguous:
    2 
    -- b-0.0.0:Foo
    3 
    -- d-0.0.0:Foo
    4 
    -module name 'Foo' is ambiguous:
    5 
    -- b-0.0.0:Foo
    6 
    -- d-0.0.0:Foo
    7 
    -module name 'Foo' is ambiguous:
    8 
    -- b-0.0.0:Foo
    9 
    -- d-0.0.0:Foo
    1 
    +<interactive>: error: [GHCi-59019]
    2 
    +    Module name ‘Foo’ is ambiguous
    3 
    +    - Foo:b-0.0.0
    4 
    +    - Foo:d-0.0.0
    5 
    +
    6 
    +<interactive>: error: [GHCi-59019]
    7 
    +    Module name ‘Foo’ is ambiguous
    8 
    +    - Foo:b-0.0.0
    9 
    +    - Foo:d-0.0.0
    10 
    +
    11 
    +<interactive>: error: [GHCi-59019]
    12 
    +    Module name ‘Foo’ is ambiguous
    13 
    +    - Foo:b-0.0.0
    14 
    +    - Foo:d-0.0.0
    15 
    +

  • testsuite/tests/ghci/prog021/A.hs
    1 
    +module A (f) where
    2 
    +
    3 
    +f x = [x]
    4 
    +
    5 
    +g x = Just x

  • testsuite/tests/ghci/prog021/B.hs
    1 
    +module B where
    2 
    +
    3 
    +import A
    4 
    +
    5 
    +h = f

  • testsuite/tests/ghci/prog021/Makefile
    1 
    +TOP=../../..
    2 
    +include $(TOP)/mk/boilerplate.mk
    3 
    +include $(TOP)/mk/test.mk

  • testsuite/tests/ghci/prog021/prog021.T
    1 
    +test('prog021',
    2 
    +     [req_interp,
    3 
    +      cmd_prefix('ghciWayFlags=' + config.ghci_way_flags),
    4 
    +      extra_files(['A.hs', 'B.hs', 'prog021.script'])
    5 
    +     ],
    6 
    +     ghci_script, ['prog021.script'])

  • testsuite/tests/ghci/prog021/prog021.script
    1 
    +-- Loads all targets
    2 
    +:load A B
    3 
    +:m + A B
    4 
    +f 5
    5 
    +g 5
    6 
    +h 5
    7 
    +-- Load only one target
    8 
    +:reload A
    9 
    +:m A
    10 
    +putStrLn "B is not loaded, we can't add it to the context"
    11 
    +:m + B
    12 
    +f 5
    13 
    +putStrLn "`g` and `h` are not in scope"
    14 
    +g 5
    15 
    +h 5

  • testsuite/tests/ghci/prog021/prog021.stderr
    1 
    +<no location info>: error: [GHC-35235]
    2 
    +    Could not find module ‘B’.
    3 
    +    It is not a module in the current program, or in any known package.
    4 
    +
    5 
    +<interactive>:14:1: error: [GHC-88464]
    6 
    +    Variable not in scope: g :: t0 -> t
    7 
    +
    8 
    +<interactive>:15:1: error: [GHC-88464]
    9 
    +    Variable not in scope: h :: t0 -> t
    10 
    +

  • testsuite/tests/ghci/prog021/prog021.stdout
    1 
    +[5]
    2 
    +Just 5
    3 
    +[5]
    4 
    +B is not loaded, we can't add it to the context
    5 
    +[5]
    6 
    +`g` and `h` are not in scope

  • testsuite/tests/ghci/scripts/ghci021.stderr
    1 
    -<no location info>: error: [GHC-82272]
    2 
    -    module ‘ThisDoesNotExist’ cannot be found locally
    1 
    +<interactive>: error: [GHCi-81235]
    2 
    +    Module ‘ThisDoesNotExist’ cannot be found locally
    3 3

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help