Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

15 changed files:

Changes:

  • compiler/GHC/Driver/Make.hs
    ... ... @@ -116,6 +116,7 @@ import qualified Control.Monad.Catch as MC
    116 116 
     import Data.IORef
    117 117 
     import Data.Maybe
    118 118 
     import Data.List (sortOn, groupBy, sortBy)
    119 
    +import qualified Data.List as List
    119 120 
     import System.FilePath
    120 121
    121 122 
     import Control.Monad.IO.Class
    ... ... @@ -520,13 +521,14 @@ countMods (UnresolvedCycle ns) = length ns
    520 521 
     createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]
    521 522 
     createBuildPlan mod_graph maybe_top_mod =
    522 523 
         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 
    +        cycle_mod_graph   = topSortModuleGraph True  mod_graph maybe_top_mod
    525 
    +        acyclic_mod_graph = topSortModuleGraph False mod_graph maybe_top_mod
    524 526
    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 acyclic_mod_graph
    530 532 
               | otherwise = toBuildPlan cycle_mod_graph []
    531 533
    532 534 
             toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
    ... ... @@ -598,14 +600,17 @@ createBuildPlan mod_graph maybe_top_mod =
    598 600 
             collapseAcyclic [] = []
    599 601
    600 602 
             topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing
    601 
    -
    602 
    -
    603 603 
       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))])
    604 
    +    -- We need to use 'acyclic_mod_graph', since if 'maybe_top_mod' is 'Just', then the resulting module
    605 
    +    -- graph is pruned, reducing the number of 'build_plan' elements.
    606 
    +    -- We don't use the size of 'cycle_mod_graph', as it removes @.hi-boot@ modules. These are added
    607 
    +    -- later in the processing.
    608 
    +    assertPpr (sum (map countMods build_plan) == lengthMGWithSCC acyclic_mod_graph)
    609 
    +              (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (lengthMGWithSCC acyclic_mod_graph))])
    607 610 
                   build_plan
    608 
    -
    611 
    +  where
    612 
    +    lengthMGWithSCC :: [SCC a] -> Int
    613 
    +    lengthMGWithSCC = List.foldl' (\acc scc -> length scc + acc) 0
    609 614
    610 615 
     -- | Generalized version of 'load' which also supports a custom
    611 616 
     -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally

  • ghc/GHCi/UI.hs
    ... ... @@ -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
    ... ... @@ -2286,13 +2291,16 @@ unAddModule files = do
    2286 2291 
     -- | @:reload@ command
    2287 2292 
     reloadModule :: GhciMonad m => String -> m ()
    2288 2293 
     reloadModule m = do
    2289 
    -  session <- GHC.getSession
    2290 
    -  let home_unit = homeUnitId (hsc_home_unit session)
    2291 
    -  ok <- doLoadAndCollectInfo Reload (loadTargets home_unit)
    2294 
    +  loadTarget <- findLoadTarget
    2295 
    +  ok <- doLoadAndCollectInfo Reload loadTarget
    2292 2296 
       when (failed ok) failIfExprEvalMode
    2293 2297 
       where
    2294 
    -    loadTargets hu | null m    = LoadAllTargets
    2295 
    -                   | otherwise = LoadUpTo (mkModule hu (GHC.mkModuleName m))
    2298 
    +    findLoadTarget
    2299 
    +      | null m    =
    2300 
    +          pure LoadAllTargets
    2301 
    +      | otherwise = do
    2302 
    +          mod' <- lookupHomeUnitModuleName (GHC.mkModuleName m)
    2303 
    +          pure $ LoadUpTo mod'
    2296 2304
    2297 2305 
     reloadModuleDefer :: GhciMonad m => String -> m ()
    2298 2306 
     reloadModuleDefer = wrapDeferTypeErrors . reloadModule
    ... ... @@ -4747,8 +4755,11 @@ showException se =
    4747 4755 
                Just other_ghc_ex        -> putException (show other_ghc_ex)
    4748 4756 
                Nothing                  ->
    4749 4757 
                    case fromException se of
    4750 
    -               Just UserInterrupt -> putException "Interrupted."
    4751 
    -               _                  -> putException ("*** Exception: " ++ show se)
    4758 
    +                Just (GhciCommandError s) -> putException (show (GhciCommandError s))
    4759 
    +                Nothing ->
    4760 
    +                  case fromException se of
    4761 
    +                  Just UserInterrupt -> putException "Interrupted."
    4762 
    +                  _                  -> putException ("*** Exception: " ++ show se)
    4752 4763 
       where
    4753 4764 
         putException = hPutStrLn stderr
    4754 4765
    ... ... @@ -4798,15 +4809,22 @@ lookupModuleName mName = lookupQualifiedModuleName NoPkgQual mName
    4798 4809 
     lookupQualifiedModuleName :: GHC.GhcMonad m => PkgQual -> ModuleName -> m Module
    4799 4810 
     lookupQualifiedModuleName qual modl = do
    4800 4811 
       GHC.lookupAllQualifiedModuleNames qual modl >>= \case
    4801 
    -    [] -> throwGhcException (CmdLineError ("module '" ++ str ++ "' could not be found."))
    4812 
    +    [] -> throwGhciCommandError (GhciModuleError $ GhciModuleNameNotFound modl)
    4802 4813 
         [m] -> pure m
    4803 
    -    ms -> throwGhcException (CmdLineError ("module name '" ++ str ++ "' is ambiguous:\n" ++ errorMsg ms))
    4814 
    +    ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl ms)
    4815 
    +
    4816 
    +lookupHomeUnitModuleName :: GHC.GhcMonad m => ModuleName -> m HomeUnitModule
    4817 
    +lookupHomeUnitModuleName modl = do
    4818 
    +  m <- GHC.lookupLoadedHomeModuleByModuleName modl >>= \case
    4819 
    +    Nothing -> throwGhciCommandError (GhciModuleError $ GhciNoLocalModuleName modl)
    4820 
    +    Just [m] -> pure m
    4821 
    +    Just ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl ms)
    4822 
    +
    4823 
    +  if unitIsDefinite (moduleUnit m)
    4824 
    +    then pure (fmap toUnitId m)
    4825 
    +    else throwGhcException (CmdLineError ("module '" ++ str ++ "' is not from a definite unit"))
    4804 4826 
       where
    4805 4827 
         str = moduleNameString modl
    4806 
    -    errorMsg ms = intercalate "\n"
    4807 
    -      [ "- " ++ unitIdString (toUnitId (moduleUnit m)) ++ ":" ++ moduleNameString (moduleName m)
    4808 
    -      | m <- ms
    4809 
    -      ]
    4810 4828
    4811 4829 
     showModule :: Module -> String
    4812 4830 
     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/prog-mhu004/prog-mhu004a.stderr
    1 
    -module name 'Foo' is ambiguous:
    2 
    -- a-0.0.0:Foo
    3 
    -- b-0.0.0:Foo
    4 
    -module name 'Foo' is ambiguous:
    5 
    -- a-0.0.0:Foo
    6 
    -- b-0.0.0:Foo
    7 
    -module name 'Foo' is ambiguous:
    8 
    -- a-0.0.0:Foo
    9 
    -- b-0.0.0:Foo
    1 
    +<interactive>: [GHCi-59019]
    2 
    +    Module name ‘Foo’ is ambiguous
    3 
    +    - Foo:a-0.0.0
    4 
    +    - Foo:b-0.0.0
    5 
    +
    6 
    +<interactive>: [GHCi-59019]
    7 
    +    Module name ‘Foo’ is ambiguous
    8 
    +    - Foo:a-0.0.0
    9 
    +    - Foo:b-0.0.0
    10 
    +
    11 
    +<interactive>: [GHCi-59019]
    12 
    +    Module name ‘Foo’ is ambiguous
    13 
    +    - Foo:a-0.0.0
    14 
    +    - Foo:b-0.0.0

  • 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