Hannes Siebenhandl pushed to branch wip/fendor/fix-reload-targets at Glasgow Haskell Compiler / GHC

Commits:

13 changed files:

Changes:

  • 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
    ... ... @@ -601,11 +602,13 @@ createBuildPlan mod_graph maybe_top_mod =
    601 602
    602 603
    603 604 
       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))])
    605 
    +    -- The assertion needs to operate on 'cycle_mod_graph' as we prune the module graph during 'topSortModuleGraph'.
    606 
    +    assertPpr (sum (map countMods build_plan) == lengthMGWithSCC cycle_mod_graph)
    607 
    +              (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (lengthMGWithSCC cycle_mod_graph))])
    607 608 
                   build_plan
    608 
    -
    609 
    +  where
    610 
    +    lengthMGWithSCC :: [SCC a] -> Int
    611 
    +    lengthMGWithSCC = List.foldl' (\acc scc -> length scc + acc) 0
    609 612
    610 613 
     -- | Generalized version of 'load' which also supports a custom
    611 614 
     -- '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
    ... ... @@ -57,6 +98,16 @@ data GhciMessage where
    57 98 
       GhciGhcMessage     :: GhcMessage                       -> GhciMessage
    58 99 
       GhciUnknownMessage :: UnknownDiagnosticFor GhciMessage -> GhciMessage
    59 100
    101 
    +-- instance Show GhciMessage where
    102 
    +--   show = \case
    103 
    +--     GhciCommandMessage msg -> show msg
    104 
    +--     GhciGhcMessage msg -> show msg
    105 
    +--     GhciUnknownMessage msg -> show msg
    106 
    +
    107 
    +-- instance Exception GhciMessage where
    108 
    +--   fromException (SomeException e) = undefined
    109 
    +--   displayException exc = showSDocUnsafe (pprDiagnostic exc)
    110 
    +
    60 111 
     -- | A 'GhciHint' may either be a hint that GHC emitted ('GhciGhcHint')
    61 112 
     -- or one that is specific to GHCi ('GhciCommandHint').
    62 113 
     data GhciHint where
    ... ... @@ -257,6 +308,9 @@ data GhciModuleError
    257 308 
       | GhciNoResolvedModules
    258 309 
       | GhciNoModuleForName GHC.Name
    259 310 
       | GhciNoMatchingModuleExport
    311 
    +  | GhciNoLocalModuleName !GHC.ModuleName
    312 
    +  | GhciModuleNameNotFound !GHC.ModuleName
    313 
    +  | GhciAmbiguousModuleName !GHC.ModuleName ![GHC.Module]
    260 314 
       deriving Generic
    261 315
    262 316 
     instance Diagnostic GhciModuleError where
    ... ... @@ -278,6 +332,16 @@ instance Diagnostic GhciModuleError where
    278 332 
           -> "No module for" <+> ppr name
    279 333 
         GhciNoMatchingModuleExport
    280 334 
           -> "No matching export in any local modules."
    335 
    +    GhciNoLocalModuleName modl
    336 
    +      -> "Module" <+> quotes (ppr modl) <+> "cannot be found locally"
    337 
    +    GhciModuleNameNotFound modl
    338 
    +      -> "module" <+> quotes (ppr modl) <+> "could not be found."
    339 
    +    GhciAmbiguousModuleName modl candidates
    340 
    +      -> "Module name" <+> quotes (ppr modl) <+> "is ambiguous" <>
    341 
    +        vcat
    342 
    +          [ text "-" <+> ppr (GHC.moduleName m) <> colon <> ppr (GHC.moduleUnit m)
    343 
    +          | m <- candidates
    344 
    +          ]
    281 345
    282 346 
       diagnosticReason = \case
    283 347 
         GhciModuleNotFound{} ->
    ... ... @@ -294,6 +358,12 @@ instance Diagnostic GhciModuleError where
    294 358 
           ErrorWithoutFlag
    295 359 
         GhciNoMatchingModuleExport{} ->
    296 360 
           ErrorWithoutFlag
    361 
    +    GhciNoLocalModuleName{} ->
    362 
    +      ErrorWithoutFlag
    363 
    +    GhciModuleNameNotFound{} ->
    364 
    +      ErrorWithoutFlag
    365 
    +    GhciAmbiguousModuleName{} ->
    366 
    +      ErrorWithoutFlag
    297 367
    298 368 
       diagnosticHints = \case
    299 369 
         GhciModuleNotFound{} ->
    ... ... @@ -310,7 +380,12 @@ instance Diagnostic GhciModuleError where
    310 380 
           []
    311 381 
         GhciNoMatchingModuleExport{} ->
    312 382 
           []
    313 
    -
    383 
    +    GhciNoLocalModuleName{} ->
    384 
    +      []
    385 
    +    GhciModuleNameNotFound{} ->
    386 
    +      []
    387 
    +    GhciAmbiguousModuleName{} ->
    388 
    +      []
    314 389 
       diagnosticCode = constructorCode @GHCi
    315 390
    316 391 
     -- | A Diagnostic emitted by GHCi while executing a command
    ... ... @@ -487,6 +562,9 @@ type family GhciDiagnosticCode c = n | n -> c where
    487 562 
       GhciDiagnosticCode "GhciNoModuleForName"                = 21847
    488 563 
       GhciDiagnosticCode "GhciNoMatchingModuleExport"         = 59723
    489 564 
       GhciDiagnosticCode "GhciArgumentParseError"             = 35671
    565 
    +  GhciDiagnosticCode "GhciNoLocalModuleName"              = 81235
    566 
    +  GhciDiagnosticCode "GhciModuleNameNotFound"             = 40475
    567 
    +  GhciDiagnosticCode "GhciAmbiguousModuleName"            = 59019
    490 568
    491 569 
     type GhciConRecursInto :: Symbol -> Maybe Type
    492 570 
     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/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