Make GHC.Driver.Main.hscTcRnLookupRdrName to return NonEmpty

4 files changed, 27 insertions, 28 deletions

diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index b6ff27621b..976cf12b55 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -266,6 +266,7 @@ import GHC.SysTools.BaseDir (findTopDir)
 
 import Data.Data hiding (Fixity, TyCon)
 import Data.List        ( nub, isPrefixOf, partition )
+import qualified Data.List.NonEmpty as NE
 import Control.Monad
 import Data.IORef
 import System.FilePath as FilePath
@@ -445,11 +446,15 @@ ioMsgMaybe' ioA = do
 -- -----------------------------------------------------------------------------
 -- | Lookup things in the compiler's environment
 
-hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]
+hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO (NonEmpty Name)
 hscTcRnLookupRdrName hsc_env0 rdr_name
   = runInteractiveHsc hsc_env0 $
     do { hsc_env <- getHscEnv
-       ; ioMsgMaybe $ hoistTcRnMessage $ tcRnLookupRdrName hsc_env rdr_name }
+       -- tcRnLookupRdrName can return empty list only together with TcRnUnknownMessage.
+       -- Once errors has been dealt with in hoistTcRnMessage, we can enforce
+       -- this invariant in types by converting to NonEmpty.
+       ; ioMsgMaybe $ fmap (fmap (>>= NE.nonEmpty)) $ hoistTcRnMessage $
+          tcRnLookupRdrName hsc_env rdr_name }
 
 hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
 hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs
index a89227aada..7448f62234 100644
--- a/compiler/GHC/Runtime/Debugger.hs
+++ b/compiler/GHC/Runtime/Debugger.hs
@@ -49,6 +49,7 @@ import GHC.Types.TyThing
 import Control.Monad
 import Control.Monad.Catch as MC
 import Data.List ( (\\), partition )
+import qualified Data.List.NonEmpty as NE
 import Data.Maybe
 import Data.IORef
 
@@ -57,7 +58,7 @@ import Data.IORef
 -------------------------------------
 pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()
 pprintClosureCommand bindThings force str = do
-  tythings <- (catMaybes . concat) `liftM`
+  tythings <- (catMaybes . concatMap NE.toList) `liftM`
                  mapM (\w -> GHC.parseName w >>=
                                 mapM GHC.lookupName)
                       (words str)
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index 0b62544433..74eba30421 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -121,6 +121,7 @@ import Data.Either
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
 import Data.List (find,intercalate)
+import Data.List.NonEmpty (NonEmpty)
 import Control.Monad
 import Control.Monad.Catch as MC
 import Data.Array
@@ -903,7 +904,7 @@ getRdrNamesInScope = withSession $ \hsc_env -> do
 
 -- | Parses a string as an identifier, and returns the list of 'Name's that
 -- the identifier can refer to in the current interactive context.
-parseName :: GhcMonad m => String -> m [Name]
+parseName :: GhcMonad m => String -> m (NonEmpty Name)
 parseName str = withSession $ \hsc_env -> liftIO $
    do { lrdr_name <- hscParseIdentifier hsc_env str
       ; hscTcRnLookupRdrName hsc_env lrdr_name }
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 376d0626e7..418502f306 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -1057,10 +1057,7 @@ installInteractivePrint :: GhciMonad m => Maybe String -> Bool -> m ()
 installInteractivePrint Nothing _  = return ()
 installInteractivePrint (Just ipFun) exprmode = do
   ok <- trySuccess $ do
-                names <- GHC.parseName ipFun
-                let name = case names of
-                             name':_ -> name'
-                             [] -> panic "installInteractivePrint"
+                name NE.:| _ <- GHC.parseName ipFun
                 modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
                                       in he{hsc_IC = new_ic})
                 return Succeeded
@@ -1599,7 +1596,7 @@ infoThing allInfo str = do
     names     <- GHC.parseName str
     mb_stuffs <- mapM (GHC.getInfo allInfo) names
     let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)
-                                     (catMaybes mb_stuffs)
+                                     (catMaybes (NE.toList mb_stuffs))
     return $ vcat (intersperse (text "") $ map pprInfo filtered)
 
   -- Filter out names whose parent is also there. Good
@@ -1920,7 +1917,7 @@ docCmd s  = do
 
   docs <- traverse (buildDocComponents s) names
 
-  let sdocs = pprDocs docs
+  let sdocs = pprDocs (NE.toList docs)
       sdocs' = vcat (intersperse (text "") sdocs)
   sdoc <- showSDocForUser' sdocs'
   liftIO (putStrLn sdoc)
@@ -3657,7 +3654,7 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do          -- #3000
     createInscope :: GhciMonad m => String -> m [(String, Module)]
     createInscope str_rdr = do
         names <- GHC.parseName str_rdr
-        pure $ zip (repeat str_rdr) $ GHC.nameModule <$> names
+        pure $ map (str_rdr, ) $ NE.toList $ GHC.nameModule <$> names
 
     -- For every top-level identifier in scope, add the bids of the nested
     -- declarations. See Note [Field modBreaks_decls] in GHC.ByteCode.Types
@@ -4109,9 +4106,7 @@ breakById inp = do
     lookupModuleInscope :: GhciMonad m => String -> m (Maybe Module)
     lookupModuleInscope mod_top_lvl = do
         names <- GHC.parseName mod_top_lvl
-        pure $ listToMaybe $ GHC.nameModule <$> names
-          -- if GHC.parseName succeeds `names` is not empty!
-          -- if it fails, the last line will not be evaluated.
+        pure $ Just $ NE.head $ GHC.nameModule <$> names
 
     -- Lookup the Module of a module name in the module graph
     lookupModuleInGraph :: GhciMonad m => String -> m (Maybe Module)
@@ -4644,20 +4639,17 @@ wantNameFromInterpretedModule :: GHC.GhcMonad m
                               -> m ()
 wantNameFromInterpretedModule noCanDo str and_then =
   handleSourceError GHC.printException $ do
-   names <- GHC.parseName str
-   case names of
-      []    -> return ()
-      (n:_) -> do
-            let modl = assert (isExternalName n) $ GHC.nameModule n
-            if not (GHC.isExternalName n)
-               then noCanDo n $ ppr n <>
-                                text " is not defined in an interpreted module"
-               else do
-            is_interpreted <- GHC.moduleIsInterpreted modl
-            if not is_interpreted
-               then noCanDo n $ text "module " <> ppr modl <>
-                                text " is not interpreted"
-               else and_then n
+    n NE.:| _ <- GHC.parseName str
+    let modl = assert (isExternalName n) $ GHC.nameModule n
+    if not (GHC.isExternalName n)
+       then noCanDo n $ ppr n <>
+                        text " is not defined in an interpreted module"
+       else do
+    is_interpreted <- GHC.moduleIsInterpreted modl
+    if not is_interpreted
+       then noCanDo n $ text "module " <> ppr modl <>
+                        text " is not interpreted"
+       else and_then n
 
 clearCaches :: GhciMonad m => m ()
 clearCaches = discardActiveBreakPoints