Don't add targets that can't be found in GHCi

When using the :add command in haxlsh/ghci, a module/file that can't
be found is still added to the list of targets, resulting in an error
message for the bad module/file for every subsequent usage of the
command. The add command should verify that the module/file can be
found before adding it to the list of targets.

Also add a ":show targets" command to show the currently added list of
commands, and an ":unadd" command to remove a target.

Test Plan:
Add a new GHCi testcase that checks that :add doesn't remember either
files or modules that could not be found, and that both the new :show
and :unadd commands work as expected.

Reviewers: simonmar, bgamari

Reviewed By: simonmar

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #14676

Differential Revision: https://phabricator.haskell.org/D4321

4 files changed, 55 insertions, 1 deletions

diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 01c8505562..b83ceeb7d9 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -43,6 +43,7 @@ import GHCi.RemoteTypes
 import GHCi.BreakArray
 import DynFlags
 import ErrUtils hiding (traceCmd)
+import Finder
 import GhcMonad ( modifySession )
 import qualified GHC
 import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),
@@ -208,6 +209,7 @@ ghciCommands = map mkCmd [
   ("stepmodule",keepGoing stepModuleCmd,        completeIdentifier),
   ("type",      keepGoing' typeOfExpr,          completeExpression),
   ("trace",     keepGoing traceCmd,             completeExpression),
+  ("unadd",     keepGoingPaths unAddModule,     completeFilename),
   ("undef",     keepGoing undefineMacro,        completeMacro),
   ("unset",     keepGoing unsetOptions,         completeSetOptions),
   ("where",     keepGoing whereCmd,             noCompletion)
@@ -305,6 +307,7 @@ defFullHelpText =
   "   :type <expr>                show the type of <expr>\n" ++
   "   :type +d <expr>             show the type of <expr>, defaulting type variables\n" ++
   "   :type +v <expr>             show the type of <expr>, with its specified tyvars\n" ++
+  "   :unadd <module> ...         remove module(s) from the current target set\n" ++
   "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
   "   :!<command>                 run the shell command <command>\n" ++
   "\n" ++
@@ -371,6 +374,7 @@ defFullHelpText =
   "   :show packages              show the currently active package flags\n" ++
   "   :show paths                 show the currently active search paths\n" ++
   "   :show language              show the currently active language flags\n" ++
+  "   :show targets               show the current set of targets\n" ++
   "   :show <setting>             show value of <setting>, which is one of\n" ++
   "                                  [args, prog, editor, stop]\n" ++
   "   :showi language             show language flags for interactive evaluation\n" ++
@@ -1657,9 +1661,39 @@ addModule files = do
   lift revertCAFs -- always revert CAFs on load/add.
   files' <- mapM expandPath files
   targets <- mapM (\m -> GHC.guessTarget m Nothing) files'
+  targets' <- filterM checkTarget targets
   -- remove old targets with the same id; e.g. for :add *M
+  mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets' ]
+  mapM_ GHC.addTarget targets'
+  _ <- doLoadAndCollectInfo False LoadAllTargets
+  return ()
+  where
+    checkTarget :: Target -> InputT GHCi Bool
+    checkTarget (Target (TargetModule m) _ _) = checkTargetModule m
+    checkTarget (Target (TargetFile f _) _ _) = liftIO $ checkTargetFile f
+
+    checkTargetModule :: ModuleName -> InputT GHCi Bool
+    checkTargetModule m = do
+      hsc_env <- GHC.getSession
+      result <- liftIO $
+        Finder.findImportedModule hsc_env m (Just (fsLit "this"))
+      case result of
+        Found _ _ -> return True
+        _ -> (liftIO $ putStrLn $
+          "Module " ++ moduleNameString m ++ " not found") >> return False
+
+    checkTargetFile :: String -> IO Bool
+    checkTargetFile f = do
+      exists <- (doesFileExist f) :: IO Bool
+      unless exists $ putStrLn $ "File " ++ f ++ " not found"
+      return exists
+
+-- | @:unadd@ command
+unAddModule :: [FilePath] -> InputT GHCi ()
+unAddModule files = do
+  files' <- mapM expandPath files
+  targets <- mapM (\m -> GHC.guessTarget m Nothing) files'
   mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
-  mapM_ GHC.addTarget targets
   _ <- doLoadAndCollectInfo False LoadAllTargets
   return ()
 
@@ -2779,6 +2813,7 @@ showCmd str = do
             , action "language"   $ showLanguages
             , hidden "languages"  $ showLanguages -- backwards compat
             , hidden "lang"       $ showLanguages -- useful abbreviation
+            , action "targets"    $ showTargets
             ]
 
     case words str of
@@ -2941,6 +2976,14 @@ showLanguages' show_all dflags =
            Nothing -> Just Haskell2010
            other   -> other
 
+showTargets :: GHCi ()
+showTargets = mapM_ showTarget =<< GHC.getTargets
+  where
+    showTarget :: Target -> GHCi ()
+    showTarget (Target (TargetFile f _) _ _) = liftIO (putStrLn f)
+    showTarget (Target (TargetModule m) _ _) =
+      liftIO (putStrLn $ moduleNameString m)
+
 -- -----------------------------------------------------------------------------
 -- Completion
 
diff --git a/testsuite/tests/ghci/scripts/T14676.script b/testsuite/tests/ghci/scripts/T14676.script
new file mode 100644
index 0000000000..9cfe6934fe
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T14676.script
@@ -0,0 +1,7 @@
+:add Notfound.hs
+:add NotFound
+:show targets
+:add prog002/A1.hs
+:show targets
+:unadd prog002/A1.hs
+:show targets
diff --git a/testsuite/tests/ghci/scripts/T14676.stdout b/testsuite/tests/ghci/scripts/T14676.stdout
new file mode 100644
index 0000000000..c3e9fbd6b4
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T14676.stdout
@@ -0,0 +1,3 @@
+File Notfound.hs not found
+Module NotFound not found
+prog002/A1.hs
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index ced484190a..997203f88d 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -263,3 +263,4 @@ test('T13407', normal, ghci_script, ['T13407.script'])
 test('T13963', normal, ghci_script, ['T13963.script'])
 test('T14342', [extra_hc_opts("-XOverloadedStrings -XRebindableSyntax")],
                ghci_script, ['T14342.script'])
+test('T14676', extra_files(['../prog002']), ghci_script, ['T14676.script'])