[Git][ghc/ghc][master] 3 commits: GHCi.UI: fix various usages of head and tail
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Dec 21 02:16:57 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
befe6ff8 by Bodigrim at 2022-12-20T21:16:37-05:00
GHCi.UI: fix various usages of head and tail
- - - - -
666d0ba7 by Bodigrim at 2022-12-20T21:16:37-05:00
GHCi.UI: avoid head and tail in parseCallEscape and around
- - - - -
5d96fd50 by Bodigrim at 2022-12-20T21:16:37-05:00
Make GHC.Driver.Main.hscTcRnLookupRdrName to return NonEmpty
- - - - -
4 changed files:
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Runtime/Debugger.hs
- compiler/GHC/Runtime/Eval.hs
- ghc/GHCi/UI.hs
Changes:
=====================================
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
=====================================
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)
=====================================
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 }
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -122,7 +122,7 @@ import qualified Data.ByteString.Char8 as BS
import Data.Char
import Data.Function
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
-import Data.List ( elemIndices, find, intercalate, intersperse,
+import Data.List ( elemIndices, find, intercalate, intersperse, minimumBy,
isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) )
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as S
@@ -941,23 +941,26 @@ getInfoForPrompt = do
return (dots <> context_bit, modules_names, line)
-parseCallEscape :: String -> (String, String)
-parseCallEscape s
- | not (all isSpace beforeOpen) = ("", "")
- | null sinceOpen = ("", "")
- | null sinceClosed = ("", "")
- | null cmd = ("", "")
- | otherwise = (cmd, tail sinceClosed)
- where
- (beforeOpen, sinceOpen) = span (/='(') s
- (cmd, sinceClosed) = span (/=')') (tail sinceOpen)
+-- | Takes a string, presumably following "%call", and tries to parse
+-- a command and arguments in parentheses:
+--
+-- > parseCallEscape " (cmd arg1 arg2)rest" = Just ("cmd" :| ["arg1", "arg2"], "rest")
+-- > parseCallEscape "( )rest" = Nothing
+--
+parseCallEscape :: String -> Maybe (NE.NonEmpty String, String)
+parseCallEscape s = case dropWhile isSpace s of
+ '(' : sinceOpen -> case span (/= ')') sinceOpen of
+ (call, ')' : sinceClosed)
+ | cmd : args <- words call -> Just (cmd NE.:| args, sinceClosed)
+ _ -> Nothing
+ _ -> Nothing
checkPromptStringForErrors :: String -> Maybe String
checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =
case parseCallEscape xs of
- ("", "") -> Just ("Incorrect %call syntax. " ++
+ Nothing -> Just ("Incorrect %call syntax. " ++
"Should be %call(a command and arguments).")
- (_, afterClosed) -> checkPromptStringForErrors afterClosed
+ Just (_, afterClosed) -> checkPromptStringForErrors afterClosed
checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs
checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs
checkPromptStringForErrors "" = Nothing
@@ -1010,10 +1013,12 @@ generatePromptFunctionFromString promptS modules_names line =
processString ('%':'V':xs) =
liftM ((text $ showVersion compilerVersion) <>) (processString xs)
processString ('%':'c':'a':'l':'l':xs) = do
+ -- Input has just been validated by parseCallEscape
+ let (cmd NE.:| args, afterClosed) = fromJust $ parseCallEscape xs
respond <- liftIO $ do
(code, out, err) <-
readProcessWithExitCode
- (head list_words) (tail list_words) ""
+ cmd args ""
`catchIO` \e -> return (ExitFailure 1, "", show e)
case code of
ExitSuccess -> return out
@@ -1021,9 +1026,6 @@ generatePromptFunctionFromString promptS modules_names line =
hPutStrLn stderr err
return ""
liftM ((text respond) <>) (processString afterClosed)
- where
- (cmd, afterClosed) = parseCallEscape xs
- list_words = words cmd
processString ('%':'%':xs) =
liftM ((char '%') <>) (processString xs)
processString (x:xs) =
@@ -1055,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
@@ -1374,12 +1373,13 @@ afterRunStmt step_here run_result = do
show_types <- isOptionSet ShowType
when show_types $ printTypeOfNames names
GHC.ExecBreak names mb_info
- | isNothing mb_info ||
- step_here (GHC.resumeSpan $ head resumes) -> do
+ | first_resume : _ <- resumes
+ , isNothing mb_info ||
+ step_here (GHC.resumeSpan first_resume) -> do
mb_id_loc <- toBreakIdAndLocation mb_info
let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
if (null bCmd)
- then printStoppedAtBreakInfo (head resumes) names
+ then printStoppedAtBreakInfo first_resume names
else enqueueCommands [bCmd]
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
@@ -1596,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
@@ -1917,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)
@@ -2607,15 +2607,14 @@ guessCurrentModule :: GHC.GhcMonad m => String -> m Module
-- Guess which module the user wants to browse. Pick
-- modules that are interpreted first. The most
-- recently-added module occurs last, it seems.
-guessCurrentModule cmd
- = do imports <- GHC.getContext
- when (null imports) $ throwGhcException $
- CmdLineError (':' : cmd ++ ": no current module")
- case (head imports) of
- IIModule m -> GHC.findQualifiedModule NoPkgQual m
- IIDecl d -> do
- pkgqual <- GHC.renameRawPkgQualM (unLoc $ ideclName d) (ideclPkgQual d)
- GHC.findQualifiedModule pkgqual (unLoc (ideclName d))
+guessCurrentModule cmd = do
+ imports <- GHC.getContext
+ case imports of
+ [] -> throwGhcException $ CmdLineError (':' : cmd ++ ": no current module")
+ IIModule m : _ -> GHC.findQualifiedModule NoPkgQual m
+ IIDecl d : _ -> do
+ pkgqual <- GHC.renameRawPkgQualM (unLoc $ ideclName d) (ideclPkgQual d)
+ GHC.findQualifiedModule pkgqual (unLoc (ideclName d))
-- without bang, show items in context of their parents and omit children
-- with bang, show class methods and data constructors separately, and
@@ -3507,18 +3506,15 @@ completeCmd argLine0 = case parseLine argLine0 of
liftIO $ print r
_ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")
where
- parseLine argLine
- | null argLine = Nothing
- | null rest1 = Nothing
- | otherwise = (,,) dom <$> resRange <*> s
- where
- (dom, rest1) = breakSpace argLine
- (rng, rest2) = breakSpace rest1
- resRange | head rest1 == '"' = parseRange ""
- | otherwise = parseRange rng
- s | head rest1 == '"' = readMaybe rest1 :: Maybe String
- | otherwise = readMaybe rest2
- breakSpace = fmap (dropWhile isSpace) . break isSpace
+ parseLine [] = Nothing
+ parseLine argLine = case breakSpace argLine of
+ (_, []) -> Nothing
+ (dom, rest1@('"' : _)) -> (dom,,) <$> parseRange "" <*> (readMaybe rest1 :: Maybe String)
+ (dom, rest1) -> (dom,,) <$> parseRange rng <*> readMaybe rest2
+ where
+ (rng, rest2) = breakSpace rest1
+
+ breakSpace = fmap (dropWhile isSpace) . break isSpace
takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub
@@ -3658,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
@@ -3666,7 +3662,7 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000
addNestedDecls (ident, mod) = do
(_, decls) <- getModBreak mod
let (mod_str, topLvl, _) = splitIdent ident
- ident_decls = filter ((topLvl ==) . head) $ elems decls
+ ident_decls = [ elm | elm@(el : _) <- elems decls, el == topLvl ]
bids = nub $ declPath <$> ident_decls
pure $ map (combineModIdent mod_str) bids
@@ -3843,7 +3839,7 @@ enclosingTickSpan md (RealSrcSpan src _) = do
massert (inRange (bounds ticks) line)
let enclosing_spans = [ pan | (_,pan) <- ticks ! line
, realSrcSpanEnd pan >= realSrcSpanEnd src]
- return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans
+ return . minimumBy leftmostLargestRealSrcSpan $ enclosing_spans
where
leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering
@@ -4110,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 $ Just $ head $ 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)
@@ -4645,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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/36c5d98e54c5ab9ede8c06f4501ed1ac83069f90...5d96fd5060958238d5b5c98f14a8b9221c87df93
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/36c5d98e54c5ab9ede8c06f4501ed1ac83069f90...5d96fd5060958238d5b5c98f14a8b9221c87df93
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221220/b8ab2ed0/attachment-0001.html>
More information about the ghc-commits
mailing list