- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/spj-apporv-Oct24] - Make a new variant `GeneratedSrcSpan` in `SrcSpan` for HIEAst Nodes
by Apoorv Ingle (＠ani) 20 Jan '26

20 Jan '26

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 97246591 by Apoorv Ingle at 2026-01-20T08:52:06-06:00 - Make a new variant `GeneratedSrcSpan` in `SrcSpan` for HIEAst Nodes - remove UnhelpfulGenerated from UnhelpfulSpanReason and into new datatype GeneratedSrcSpanDetails - Fixes T23540, tcfail181 - - - - - 30 changed files: - compiler/GHC.hs - compiler/GHC/Hs/DocString.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Utils.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Names.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Types/CtLoc.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/SrcLoc.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Logger.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Info.hs - utils/check-exact/ExactPrint.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -288,7 +288,7 @@ module GHC ( SrcLoc(..), RealSrcLoc, mkSrcLoc, noSrcLoc, srcLocFile, srcLocLine, srcLocCol, - SrcSpan(..), RealSrcSpan, + SrcSpan(..), RealSrcSpan, GeneratedSrcSpanDetails (..), mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, srcSpanStart, srcSpanEnd, srcSpanFile, @@ -1617,6 +1617,7 @@ addSourceToTokens _ _ [] = [] addSourceToTokens loc buf (t@(L span _) : ts) = case span of UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts + GeneratedSrcSpan _ -> (t,"") : addSourceToTokens loc buf ts RealSrcSpan s _ -> (t,str) : addSourceToTokens newLoc newBuf ts where (newLoc, newBuf, str) = go "" loc buf @@ -1637,12 +1638,14 @@ showRichTokenStream ts = go startLoc ts "" where sourceFile = getFile $ map (getLoc . fst) ts getFile [] = panic "showRichTokenStream: No source file found" getFile (UnhelpfulSpan _ : xs) = getFile xs + getFile (GeneratedSrcSpan _ : xs) = getFile xs getFile (RealSrcSpan s _ : _) = srcSpanFile s startLoc = mkRealSrcLoc sourceFile 1 1 go _ [] = id go loc ((L span _, str):ts) = case span of UnhelpfulSpan _ -> go loc ts + GeneratedSrcSpan _ -> go loc ts RealSrcSpan s _ | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++) . (str ++) ===================================== compiler/GHC/Hs/DocString.hs ===================================== @@ -172,7 +172,7 @@ isEmptyDocString (GeneratedDocString x) = nullHDSC x docStringChunks :: HsDocString -> [LHsDocStringChunk] docStringChunks (MultiLineDocString _ (x:|xs)) = x:xs docStringChunks (NestedDocString _ x) = [x] -docStringChunks (GeneratedDocString x) = [L (UnhelpfulSpan UnhelpfulGenerated) x] +docStringChunks (GeneratedDocString x) = [L (GeneratedSrcSpan UnhelpfulGenerated) x] -- | Pretty print with decorators, exactly as the user wrote it pprHsDocString :: HsDocString -> SDoc ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -487,10 +487,10 @@ getSrcSpanDs = do { env <- getLclEnv ; return (RealSrcSpan (dsl_loc env) Strict.Nothing) } putSrcSpanDs :: SrcSpan -> DsM a -> DsM a -putSrcSpanDs (UnhelpfulSpan {}) thing_inside - = thing_inside putSrcSpanDs (RealSrcSpan real_span _) thing_inside = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside +putSrcSpanDs _ thing_inside + = thing_inside putSrcSpanDsA :: EpAnn ann -> DsM a -> DsM a putSrcSpanDsA loc = putSrcSpanDs (locA loc) ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -121,7 +121,7 @@ addTicksToBinds logger cfg , blackList = Set.fromList $ mapMaybe (\tyCon -> case getSrcSpan (tyConName tyCon) of RealSrcSpan l _ -> Just l - UnhelpfulSpan _ -> Nothing) + _ -> Nothing) tyCons , density = mkDensity tickish $ ticks_profAuto cfg , this_mod = mod @@ -1192,7 +1192,7 @@ getFileName = fileName `liftM` getEnv isGoodSrcSpan' :: SrcSpan -> Bool isGoodSrcSpan' pos@(RealSrcSpan _ _) = srcSpanStart pos /= srcSpanEnd pos -isGoodSrcSpan' (UnhelpfulSpan _) = False +isGoodSrcSpan' _ = False isGoodTickSrcSpan :: SrcSpan -> TM Bool isGoodTickSrcSpan pos = do @@ -1218,11 +1218,11 @@ bindLocals from (TM m) = TM $ \env st -> withBlackListed :: SrcSpan -> TM a -> TM a withBlackListed (RealSrcSpan ss _) = withEnv (\ env -> env { blackList = Set.insert ss (blackList env) }) -withBlackListed (UnhelpfulSpan _) = id +withBlackListed _ = id isBlackListed :: SrcSpan -> TM Bool isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList env), noFVs, st) -isBlackListed (UnhelpfulSpan _) = return False +isBlackListed _ = return False -- the tick application inherits the source position of its -- expression argument to support nested box allocations ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -251,6 +251,11 @@ getUnlocatedEvBinds file = do let node = Node (mkSourcedNodeInfo org ni) spn [] ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e] in (xs,node:ys) + GeneratedSrcSpan (OrigSpan spn) + | srcSpanFile spn == file -> + let node = Node (mkSourcedNodeInfo org ni) spn [] + ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e] + in (xs,node:ys) _ -> (mkNodeInfo e : xs,ys) (nis,asts) = foldr go ([],[]) elts @@ -419,6 +424,7 @@ getRealSpanA la = getRealSpan (locA la) getRealSpan :: SrcSpan -> Maybe Span getRealSpan (RealSrcSpan sp _) = Just sp +getRealSpan (GeneratedSrcSpan (OrigSpan sp)) = Just sp getRealSpan _ = Nothing grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns) @@ -606,36 +612,39 @@ instance ToHie (Context (Located a)) => ToHie (Context (LocatedN a)) where instance ToHie (Context (Located a)) => ToHie (Context (LocatedA a)) where toHie (C c (L l a)) = toHie (C c (L (locA l) a)) -instance ToHie (Context (Located Var)) where - toHie c = case c of - C context (L (RealSrcSpan span _) name') - | varUnique name' == mkBuiltinUnique 1 -> pure [] - -- `mkOneRecordSelector` makes a field var using this unique, which we ignore - | otherwise -> do - m <- lift $ gets name_remapping - org <- ask - let name = case lookupNameEnv m (varName name') of - Just var -> var - Nothing-> name' - ty = case isDataConId_maybe name' of +toHieCtxLocVar :: ContextInfo -> RealSrcSpan -> Var -> HieM [HieAST Type] +toHieCtxLocVar context span name' + | varUnique name' == mkBuiltinUnique 1 = pure [] + -- `mkOneRecordSelector` makes a field var using this unique, which we ignore + | otherwise = do + m <- lift $ gets name_remapping + org <- ask + let name = case lookupNameEnv m (varName name') of + Just var -> var + Nothing-> name' + ty = case isDataConId_maybe name' of Nothing -> varType name' Just dc -> dataConWrapperType dc -- insert the entity info for the name into the entity_infos map - insertEntityInfo (varName name) $ idEntityInfo name - insertEntityInfo (varName name') $ idEntityInfo name' - pure - [Node - (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ - M.singleton (Right $ varName name) + insertEntityInfo (varName name) $ idEntityInfo name + insertEntityInfo (varName name') $ idEntityInfo name' + pure [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ + M.singleton (Right $ varName name) (IdentifierDetails (Just ty) (S.singleton context))) - span - []] + span + []] + +instance ToHie (Context (Located Var)) where + toHie c = case c of + C context (L (RealSrcSpan span _) name') -> toHieCtxLocVar context span name' + C context (L (GeneratedSrcSpan (OrigSpan span)) name') -> toHieCtxLocVar context span name' C (EvidenceVarBind i _ sp) (L _ name) -> do addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp) pure [] _ -> pure [] + instance ToHie (Context (Located Name)) where toHie c = case c of C context (L (RealSrcSpan span _) name') ===================================== compiler/GHC/Iface/Ext/Utils.hs ===================================== @@ -322,6 +322,16 @@ getNameScopeAndBinding n asts = case nameSrcSpan n of scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets) let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) return $ Just (scopes, getFirst binding) + GeneratedSrcSpan (OrigSpan sp) -> do -- @Maybe + ast <- M.lookup (HiePath (srcSpanFile sp)) asts + defNode <- selectLargestContainedBy sp ast + getFirst $ foldMap First $ do -- @[] + node <- flattenAst defNode + dets <- maybeToList + $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo node + scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets) + let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) + return $ Just (scopes, getFirst binding) _ -> Nothing getScopeFromContext :: ContextInfo -> Maybe [Scope] @@ -377,6 +387,7 @@ selectSmallestContaining sp node definedInAsts :: M.Map HiePath (HieAST a) -> Name -> Bool definedInAsts asts n = case nameSrcSpan n of RealSrcSpan sp _ -> M.member (HiePath (srcSpanFile sp)) asts + GeneratedSrcSpan (OrigSpan sp) -> M.member (HiePath (srcSpanFile sp)) asts _ -> False getEvidenceBindDeps :: ContextInfo -> [Name] @@ -527,6 +538,10 @@ locOnly (RealSrcSpan span _) = do org <- ask let e = mkSourcedNodeInfo org $ emptyNodeInfo pure [Node e span []] +locOnly (GeneratedSrcSpan (OrigSpan span)) = do + org <- ask + let e = mkSourcedNodeInfo org $ emptyNodeInfo + pure [Node e span []] locOnly _ = pure [] locOnlyE :: Monad m => EpaLocation -> ReaderT NodeOrigin m [HieAST a] @@ -536,6 +551,7 @@ locOnlyE _ = pure [] mkScope :: (HasLoc a) => a -> Scope mkScope a = case getHasLoc a of (RealSrcSpan sp _) -> LocalScope sp + (GeneratedSrcSpan (OrigSpan sp)) -> LocalScope sp _ -> NoScope combineScopes :: Scope -> Scope -> Scope @@ -567,6 +583,7 @@ makeNode x spn = do org <- ask pure $ case spn of RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []] + GeneratedSrcSpan (OrigSpan span) -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []] _ -> [] where cons = mkFastString . show . toConstr $ x @@ -593,6 +610,8 @@ makeTypeNode x spn etyp = do pure $ case spn of RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []] + GeneratedSrcSpan (OrigSpan span) -> + [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []] _ -> [] where cons = mkFastString . show . toConstr $ x ===================================== compiler/GHC/Parser/HaddockLex.x ===================================== @@ -145,6 +145,7 @@ lexStringLiteral identParser (L l sl@(StringLiteral _ fs _)) plausibleIdents = case l of RealSrcSpan span _ -> [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) bs] UnhelpfulSpan reason -> [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc bs] + GeneratedSrcSpan span -> [(GeneratedSrcSpan span, tok) | (_, tok) <- alexScanTokens fakeLoc bs] fakeLoc = mkRealSrcLoc nilFS 0 0 @@ -166,6 +167,8 @@ lexHsDoc identParser doc = = [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) s] plausibleIdents (L (UnhelpfulSpan reason) (HsDocStringChunk s)) = [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc s] -- preserve the original reason + plausibleIdents (L (GeneratedSrcSpan span) (HsDocStringChunk s)) + = [(GeneratedSrcSpan span, tok) | (_, tok) <- alexScanTokens fakeLoc s] -- preserve the original reason fakeLoc = mkRealSrcLoc nilFS 0 0 @@ -181,11 +184,12 @@ validateIdentWith identParser mloc str0 = buffer = stringBufferFromByteString str0 realSrcLc = case mloc of RealSrcSpan loc _ -> realSrcSpanStart loc + GeneratedSrcSpan{} -> mkRealSrcLoc nilFS 0 0 UnhelpfulSpan _ -> mkRealSrcLoc nilFS 0 0 pstate = initParserState pflags buffer realSrcLc in case unP identParser pstate of POk _ name -> Just $ case mloc of RealSrcSpan _ _ -> reLoc name - UnhelpfulSpan _ -> L mloc (unLoc name) -- Preserve the original reason + _ -> L mloc (unLoc name) -- Preserve the original reason _ -> Nothing } ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -502,11 +502,11 @@ rnExpr (ExplicitList _ exps) then return (ExplicitList noExtField exps', fvs) else do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName - --; loc <- getSrcSpanM -- See Note [Source locations for implicit function calls] + ; loc <- getSrcSpanM -- See Note [Source locations for implicit function calls] ; let rn_list = ExplicitList noExtField exps' lit_n = mkIntegralLit (length exps) hs_lit = genHsIntegralLit lit_n - exp_list = genHsApps' (wrapGenSpan from_list_n_name) [hs_lit, wrapGenSpan rn_list] + exp_list = genHsApps' (wrapGenSpan' loc from_list_n_name) [hs_lit, wrapGenSpan rn_list] ; return ( mkExpandedExpr rn_list exp_list , fvs `plusFV` fvs') } } ===================================== compiler/GHC/Rename/Names.hs ===================================== @@ -2166,7 +2166,7 @@ insertImportMap :: GlobalRdrElt -> ImportMap -> ImportMap insertImportMap gre@(GRE { gre_imp = imp_specs }) importMap | RealSrcSpan importSpan _ <- is_dloc best_imp_spec = importMap{im_imports = insertElem importSpan gre $ im_imports importMap} - | UnhelpfulSpan UnhelpfulGenerated <- is_dloc best_imp_spec = + | GeneratedSrcSpan{} <- is_dloc best_imp_spec = importMap{im_generatedImports = insertElem (moduleName $ is_mod best_imp_spec) gre $ im_generatedImports importMap} | otherwise = importMap where @@ -2187,7 +2187,7 @@ lookupImportMap (L srcSpan ImportDecl{ideclName = L _ modName}) importMap = -- should match logic in insertImportMap case locA srcSpan of RealSrcSpan realSrcSpan _ -> realSrcSpan `Map.lookup` im_imports importMap - UnhelpfulSpan UnhelpfulGenerated -> modName `Map.lookup` im_generatedImports importMap + GeneratedSrcSpan{} -> modName `Map.lookup` im_generatedImports importMap _ -> Nothing warnUnusedImport :: GlobalRdrEnv -> ImportDeclUsage -> RnM () @@ -2557,4 +2557,3 @@ addDupDeclErr gres@(gre :| _) checkConName :: RdrName -> TcRn () checkConName name = checkErr (isRdrDataCon name || isRdrTc name) (TcRnIllegalDataCon name) - ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -17,7 +17,7 @@ module GHC.Rename.Utils ( DeprecationWarnings(..), warnIfDeprecated, checkUnusedRecordWildcard, badQualBndrErr, typeAppErr, badFieldConErr, - wrapGenSpan, wrapNoSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps', genHsExpApps, + wrapGenSpan, wrapGenSpan', wrapNoSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps', genHsExpApps, genLHsApp, genAppType, genLHsLit, genHsIntegralLit, genHsTyLit, genSimpleConPat, genVarPat, genWildPat, @@ -701,6 +701,11 @@ wrapGenSpan :: (HasAnnotation an) => a -> GenLocated an a -- See Note [Rebindable syntax and XXExprGhcRn] wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x +wrapGenSpan' :: (HasAnnotation an) => SrcSpan -> a -> GenLocated an a +wrapGenSpan' s x = case s of + RealSrcSpan s _ -> L (noAnnSrcSpan $ GeneratedSrcSpan (OrigSpan s)) x + _ -> wrapGenSpan x + wrapNoSpan :: (HasAnnotation an) => a -> GenLocated an a -- Wrap something in a "noSrcSpan" -- See Note [Rebindable syntax and XXExprGhcRn] ===================================== compiler/GHC/Runtime/Debugger/Breakpoints.hs ===================================== @@ -1,4 +1,3 @@ - -- | GHC API debugger module for finding and setting breakpoints. -- -- This module is user facing and is at least used by `GHCi` and `ghc-debugger` @@ -86,6 +85,7 @@ leftmostLargestRealSrcSpan = on compare realSrcSpanStart S.<> on (flip compare) -- | Returns the span of the largest tick containing the srcspan given enclosingTickSpan :: TickArray -> SrcSpan -> RealSrcSpan enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" +enclosingTickSpan _ (GeneratedSrcSpan _) = panic "generatedSrcSpan UnhelpfulSpan" enclosingTickSpan ticks (RealSrcSpan src _) = assert (inRange (bounds ticks) line) $ List.minimumBy leftmostLargestRealSrcSpan $ enclosing_spans @@ -295,4 +295,3 @@ getCurrentBreakModule = do return $ Just $ getBreakSourceMod ibi brks ix -> Just <$> getHistoryModule hug (resumeHistory r !! (ix-1)) - ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -123,7 +123,6 @@ expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L e_lspan e) (SyntaxExprRn t do expand_stmts_expr <- expand_do_stmts doFlavour lstmts let expansion = genHsExpApps then_op -- (>>) [ L e_lspan (mkExpandedStmt stmt doFlavour e) - -- wrapGenSpan e , expand_stmts_expr ] return $ L loc (mkExpandedStmt stmt doFlavour expansion) ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -1359,7 +1359,7 @@ expandRecordUpd :: LHsExpr GhcRn -- error context to push when typechecking -- the expanded code ) -expandRecordUpd record_expr possible_parents rbnds res_ty +expandRecordUpd record_expr@(L lspan _) possible_parents rbnds res_ty = do { -- STEP 0: typecheck the record_expr, the record to be updated. -- -- Until GHC proposal #366 is implemented, we still use the type of @@ -1527,7 +1527,7 @@ expandRecordUpd record_expr possible_parents rbnds res_ty ds_expr = HsLet noExtField let_binds (wrapGenSpan case_expr) case_expr :: HsExpr GhcRn - case_expr = HsCase RecUpd (wrapGenSpan (unLoc record_expr)) + case_expr = HsCase RecUpd (wrapGenSpan' (locA lspan) (unLoc record_expr)) $ mkMatchGroup (Generated OtherExpansion DoPmc) (wrapGenSpan matches) matches :: [LMatch GhcRn (LHsExpr GhcRn)] matches = map make_pat (NE.toList relevant_cons) ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -1480,9 +1480,11 @@ instance TH.Quasi TcM where qLocation = do { m <- getModule ; l <- getSrcSpanM ; r <- case l of + RealSrcSpan s _ -> return s + GeneratedSrcSpan l -> pprPanic "qLocation: generatedSrcSpan" + (pprGeneratedSrcSpanDetails l) UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" (ppr l) - RealSrcSpan s _ -> return s ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) , TH.loc_module = moduleNameString (moduleName m) , TH.loc_package = unitString (moduleUnit m) ===================================== compiler/GHC/Tc/Types/CtLoc.hs ===================================== @@ -257,8 +257,7 @@ setCtLocEnvLoc :: CtLocEnv -> SrcSpan -> CtLocEnv -- for the ctl_in_gen_code manipulation setCtLocEnvLoc env (RealSrcSpan loc _) = env { ctl_loc = loc, ctl_in_gen_code = False } - -setCtLocEnvLoc env loc@(UnhelpfulSpan _) +setCtLocEnvLoc env loc | isGeneratedSrcSpan loc = env { ctl_in_gen_code = True } | otherwise ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -62,7 +62,7 @@ module GHC.Tc.Utils.Monad( -- * Error management getSrcCodeOrigin, - getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, + getSrcSpanM, getRealSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, inGeneratedCode, wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, wrapLocMA_,wrapLocMA, @@ -1070,6 +1070,11 @@ getSrcSpanM :: TcRn SrcSpan -- Avoid clash with Name.getSrcLoc getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (getLclEnvLoc env) Strict.Nothing) } +getRealSrcSpanM :: TcRn RealSrcSpan + -- Avoid clash with Name.getSrcLoc +getRealSrcSpanM = do { env <- getLclEnv; return $ getLclEnvLoc env } + + -- See Note [Error contexts in generated code] inGeneratedCode :: TcRn Bool inGeneratedCode = lclEnvInGeneratedCode <$> getLclEnv ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -787,7 +787,6 @@ getSeverityColour severity = case severity of SevIgnore -> const mempty getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc -getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty getCaretDiagnostic msg_class (RealSrcSpan span _) = caretDiagnostic <$> getSrcLine (srcSpanFile span) row where @@ -861,7 +860,7 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) = caretEllipsis | multiline = "..." | otherwise = "" caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis - +getCaretDiagnostic _ _ = pure empty -- -- Queries -- ===================================== compiler/GHC/Types/Hint/Ppr.hs ===================================== @@ -19,7 +19,7 @@ import GHC.Hs.Expr () -- instance Outputable import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader (RdrName,ImpDeclSpec (..), rdrNameOcc, rdrNameSpace) -import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine) +import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine, UnhelpfulSpanReason(..), pprGeneratedSrcSpanDetails) import GHC.Unit.Module.Imported (ImportedModsVal(..)) import GHC.Unit.Types import GHC.Utils.Outputable @@ -424,6 +424,7 @@ pprSimilarName mb_tried_ns (SimilarRdrName rdr_name _gre_info how_in_scope) LocallyBoundAt loc -> case loc of UnhelpfulSpan l -> parens (ppr l) + GeneratedSrcSpan ss -> parens (pprGeneratedSrcSpanDetails ss) RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l)) ImportedBy is -> parens (text "imported from" <+> ppr (moduleName $ is_mod is)) ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -2077,9 +2077,12 @@ bestImport iss = NE.head $ NE.sortBy best iss -- False < True, so if e1 is explicit and e2 is not, we get GT compareGenerated UnhelpfulSpan{} UnhelpfulSpan{} = EQ - compareGenerated UnhelpfulSpan{} RealSrcSpan{} = LT - compareGenerated RealSrcSpan{} UnhelpfulSpan{} = GT + compareGenerated UnhelpfulSpan{} _ = LT + compareGenerated GeneratedSrcSpan{} UnhelpfulSpan{} = GT + compareGenerated GeneratedSrcSpan{} GeneratedSrcSpan{} = EQ + compareGenerated GeneratedSrcSpan{} _ = LT compareGenerated RealSrcSpan{} RealSrcSpan{} = EQ + compareGenerated RealSrcSpan{} _ = GT {- Note [Choosing the best import declaration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2212,6 +2215,7 @@ instance Outputable ImportSpec where pprLoc :: SrcSpan -> SDoc pprLoc (RealSrcSpan s _) = text "at" <+> ppr s pprLoc (UnhelpfulSpan {}) = empty +pprLoc (GeneratedSrcSpan {}) = empty -- | Indicate if the given name is the "@" operator opIsAt :: RdrName -> Bool ===================================== compiler/GHC/Types/SrcLoc.hs ===================================== @@ -30,6 +30,7 @@ module GHC.Types.SrcLoc ( -- * SrcSpan RealSrcSpan, -- Abstract SrcSpan(..), + GeneratedSrcSpanDetails(..), UnhelpfulSpanReason(..), -- ** Constructing SrcSpan @@ -49,6 +50,8 @@ module GHC.Types.SrcLoc ( pprUserSpan, unhelpfulSpanFS, srcSpanToRealSrcSpan, + pprGeneratedSrcSpanDetails, + generatedSrcSpanDetailsFS, -- ** Unsafely deconstructing SrcSpan -- These are dubious exports, because they crash on some inputs @@ -306,7 +309,7 @@ lookupSrcLoc (UnhelpfulLoc _) = const Nothing lookupSrcSpan :: SrcSpan -> Map.Map RealSrcSpan a -> Maybe a lookupSrcSpan (RealSrcSpan l _) = Map.lookup l -lookupSrcSpan (UnhelpfulSpan _) = const Nothing +lookupSrcSpan _ = const Nothing instance Outputable RealSrcLoc where ppr (SrcLoc (LexicalFastString src_path) src_line src_col) @@ -387,16 +390,22 @@ instance Semigroup BufSpan where -- or a human-readable description of a location. data SrcSpan = RealSrcSpan !RealSrcSpan !(Strict.Maybe BufSpan) -- See Note [Why Maybe BufPos] + | GeneratedSrcSpan !GeneratedSrcSpanDetails | UnhelpfulSpan !UnhelpfulSpanReason deriving (Eq, Show) -- Show is used by GHC.Parser.Lexer, because we -- derive Show for Token +-- Needed for HIE +data GeneratedSrcSpanDetails = + OrigSpan !RealSrcSpan -- this the span of the user written thing + | UnhelpfulGenerated + deriving (Eq, Show) + data UnhelpfulSpanReason = UnhelpfulNoLocationInfo | UnhelpfulWiredIn | UnhelpfulInteractive - | UnhelpfulGenerated | UnhelpfulOther !FastString deriving (Eq, Show) @@ -426,8 +435,13 @@ messages, constructing a SrcSpan without a BufSpan. instance ToJson SrcSpan where json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")] + json (GeneratedSrcSpan d) = json d json (RealSrcSpan rss _) = json rss +instance ToJson GeneratedSrcSpanDetails where + json (UnhelpfulGenerated) = JSNull + json (OrigSpan s) = json s + instance ToJson RealSrcSpan where json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)), ("start", start), @@ -444,27 +458,32 @@ instance NFData RealSrcSpan where instance NFData SrcSpan where rnf (RealSrcSpan a1 a2) = rnf a1 `seq` rnf a2 rnf (UnhelpfulSpan a1) = rnf a1 + rnf (GeneratedSrcSpan a1) = rnf a1 + +instance NFData GeneratedSrcSpanDetails where + rnf (OrigSpan s) = rnf s + rnf (UnhelpfulGenerated) = () instance NFData UnhelpfulSpanReason where rnf (UnhelpfulNoLocationInfo) = () rnf (UnhelpfulWiredIn) = () rnf (UnhelpfulInteractive) = () - rnf (UnhelpfulGenerated) = () rnf (UnhelpfulOther a1) = rnf a1 getBufSpan :: SrcSpan -> Strict.Maybe BufSpan getBufSpan (RealSrcSpan _ mbspan) = mbspan -getBufSpan (UnhelpfulSpan _) = Strict.Nothing +getBufSpan _ = Strict.Nothing + -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty noSrcSpan, generatedSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan noSrcSpan = UnhelpfulSpan UnhelpfulNoLocationInfo wiredInSrcSpan = UnhelpfulSpan UnhelpfulWiredIn interactiveSrcSpan = UnhelpfulSpan UnhelpfulInteractive -generatedSrcSpan = UnhelpfulSpan UnhelpfulGenerated +generatedSrcSpan = GeneratedSrcSpan UnhelpfulGenerated isGeneratedSrcSpan :: SrcSpan -> Bool -isGeneratedSrcSpan (UnhelpfulSpan UnhelpfulGenerated) = True +isGeneratedSrcSpan (GeneratedSrcSpan{}) = True isGeneratedSrcSpan _ = False isNoSrcSpan :: SrcSpan -> Bool @@ -515,6 +534,8 @@ mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2) combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful combineSrcSpans l (UnhelpfulSpan _) = l +combineSrcSpans (GeneratedSrcSpan{}) r = r +combineSrcSpans l (GeneratedSrcSpan{}) = l combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2) | srcSpanFile span1 == srcSpanFile span2 = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2) @@ -543,6 +564,7 @@ combineBufSpans span1 span2 = BufSpan start end -- | Convert a SrcSpan into one that represents only its first character srcSpanFirstCharacter :: SrcSpan -> SrcSpan srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l +srcSpanFirstCharacter l@(GeneratedSrcSpan {}) = l srcSpanFirstCharacter (RealSrcSpan span mbspan) = RealSrcSpan (mkRealSrcSpan loc1 loc2) (fmap mkBufSpan mbspan) where @@ -564,13 +586,13 @@ srcSpanFirstCharacter (RealSrcSpan span mbspan) = -- | Test if a 'SrcSpan' is "good", i.e. has precise location information isGoodSrcSpan :: SrcSpan -> Bool isGoodSrcSpan (RealSrcSpan _ _) = True -isGoodSrcSpan (UnhelpfulSpan _) = False +isGoodSrcSpan _ = False isOneLineSpan :: SrcSpan -> Bool -- ^ True if the span is known to straddle only one line. -- For "bad" 'SrcSpan', it returns False isOneLineSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s -isOneLineSpan (UnhelpfulSpan _) = False +isOneLineSpan _ = False isZeroWidthSpan :: SrcSpan -> Bool -- ^ True if the span has a width of zero, as returned for "virtual" @@ -578,7 +600,7 @@ isZeroWidthSpan :: SrcSpan -> Bool -- For "bad" 'SrcSpan', it returns False isZeroWidthSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s && srcSpanStartCol s == srcSpanEndCol s -isZeroWidthSpan (UnhelpfulSpan _) = False +isZeroWidthSpan _ = False -- | Tests whether the first span "contains" the other span, meaning -- that it covers at least as much source code. True where spans are equal. @@ -620,11 +642,13 @@ srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c -- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanStart :: SrcSpan -> SrcLoc srcSpanStart (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r) +srcSpanStart (GeneratedSrcSpan d) = UnhelpfulLoc (generatedSrcSpanDetailsFS d) srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b) -- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanEnd :: SrcSpan -> SrcLoc srcSpanEnd (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r) +srcSpanEnd (GeneratedSrcSpan d) = UnhelpfulLoc (generatedSrcSpanDetailsFS d) srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b) realSrcSpanStart :: RealSrcSpan -> RealSrcLoc @@ -640,7 +664,7 @@ realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s) -- | Obtains the filename for a 'SrcSpan' if it is "good" srcSpanFileName_maybe :: SrcSpan -> Maybe FastString srcSpanFileName_maybe (RealSrcSpan s _) = Just (srcSpanFile s) -srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing +srcSpanFileName_maybe _ = Nothing srcSpanToRealSrcSpan :: SrcSpan -> Maybe RealSrcSpan srcSpanToRealSrcSpan (RealSrcSpan ss _) = Just ss @@ -710,13 +734,19 @@ unhelpfulSpanFS r = case r of UnhelpfulNoLocationInfo -> fsLit "<no location info>" UnhelpfulWiredIn -> fsLit "<wired into compiler>" UnhelpfulInteractive -> fsLit "<interactive>" - UnhelpfulGenerated -> fsLit "<generated>" pprUnhelpfulSpanReason :: UnhelpfulSpanReason -> SDoc pprUnhelpfulSpanReason r = ftext (unhelpfulSpanFS r) +generatedSrcSpanDetailsFS :: GeneratedSrcSpanDetails -> FastString +generatedSrcSpanDetailsFS _ = fsLit "<generated>" + +pprGeneratedSrcSpanDetails :: GeneratedSrcSpanDetails -> SDoc +pprGeneratedSrcSpanDetails d = ftext (generatedSrcSpanDetailsFS d) + pprUserSpan :: Bool -> SrcSpan -> SDoc pprUserSpan _ (UnhelpfulSpan r) = pprUnhelpfulSpanReason r +pprUserSpan _ (GeneratedSrcSpan d) = pprGeneratedSrcSpanDetails d pprUserSpan show_path (RealSrcSpan s _) = pprUserRealSpan show_path s pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc @@ -843,15 +873,19 @@ leftmost_largest = compareSrcSpanBy $ compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering compareSrcSpanBy cmp (RealSrcSpan a _) (RealSrcSpan b _) = cmp a b -compareSrcSpanBy _ (RealSrcSpan _ _) (UnhelpfulSpan _) = LT +compareSrcSpanBy _ (RealSrcSpan _ _) _ = LT compareSrcSpanBy _ (UnhelpfulSpan _) (RealSrcSpan _ _) = GT -compareSrcSpanBy _ (UnhelpfulSpan _) (UnhelpfulSpan _) = EQ +compareSrcSpanBy _ (UnhelpfulSpan _) _ = EQ +compareSrcSpanBy _ (GeneratedSrcSpan _) (RealSrcSpan _ _) = GT +compareSrcSpanBy _ (GeneratedSrcSpan _) _ = EQ + -- | Determines whether a span encloses a given line and column index spans :: SrcSpan -> (Int, Int) -> Bool -spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" spans (RealSrcSpan span _) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span where loc = mkRealSrcLoc (srcSpanFile span) l c +spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" +spans (GeneratedSrcSpan _) _ = panic "spans GeneratedSrcSpan" -- | Determines whether a span is enclosed by another one isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -1912,8 +1912,7 @@ instance Binary UnhelpfulSpanReason where UnhelpfulNoLocationInfo -> putByte bh 0 UnhelpfulWiredIn -> putByte bh 1 UnhelpfulInteractive -> putByte bh 2 - UnhelpfulGenerated -> putByte bh 3 - UnhelpfulOther fs -> putByte bh 4 >> put_ bh fs + UnhelpfulOther fs -> putByte bh 3 >> put_ bh fs get bh = do h <- getByte bh @@ -1921,11 +1920,25 @@ instance Binary UnhelpfulSpanReason where 0 -> return UnhelpfulNoLocationInfo 1 -> return UnhelpfulWiredIn 2 -> return UnhelpfulInteractive - 3 -> return UnhelpfulGenerated _ -> UnhelpfulOther <$> get bh newtype BinSrcSpan = BinSrcSpan { unBinSrcSpan :: SrcSpan } +instance Binary GeneratedSrcSpanDetails where + put_ bh (OrigSpan ss) = do + putByte bh 0 + put_ bh $ BinSpan ss + + put_ bh UnhelpfulGenerated = do + putByte bh 1 + + get bh = do + h <- getByte bh + case h of + 0 -> do BinSpan ss <- get bh + return $ OrigSpan ss + _ -> do return UnhelpfulGenerated + -- See Note [Source Location Wrappers] instance Binary BinSrcSpan where put_ bh (BinSrcSpan (RealSrcSpan ss _sb)) = do @@ -1938,13 +1951,19 @@ instance Binary BinSrcSpan where putByte bh 1 put_ bh s + put_ bh (BinSrcSpan (GeneratedSrcSpan ss)) = do + putByte bh 2 + put_ bh ss + get bh = do h <- getByte bh case h of 0 -> do BinSpan ss <- get bh return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing) - _ -> do s <- get bh + 1 -> do s <- get bh return $ BinSrcSpan (UnhelpfulSpan s) + _ -> do ss <- get bh + return $ BinSrcSpan (GeneratedSrcSpan ss) {- ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -398,7 +398,7 @@ jsonLogActionWithHandle out logflags msg_class srcSpan msg , ("endCol", json $ srcSpanEndCol rss) ] where file = unpackFS $ srcSpanFile rss - UnhelpfulSpan _ -> JSNull + _ -> JSNull -- | The default 'LogAction' prints to 'stdout' and 'stderr'. -- @@ -707,4 +707,3 @@ class HasLogger m where class ContainsLogger t where extractLogger :: t -> Logger - ===================================== ghc/GHCi/UI.hs ===================================== @@ -2692,8 +2692,9 @@ parseSpanArg s = do -- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@ -- while simply unpacking 'UnhelpfulSpan's showSrcSpan :: SrcSpan -> String -showSrcSpan (UnhelpfulSpan s) = unpackFS (unhelpfulSpanFS s) -showSrcSpan (RealSrcSpan spn _) = showRealSrcSpan spn +showSrcSpan (UnhelpfulSpan s) = unpackFS (unhelpfulSpanFS s) +showSrcSpan (GeneratedSrcSpan d) = unpackFS (generatedSrcSpanDetailsFS d) +showSrcSpan (RealSrcSpan spn _) = showRealSrcSpan spn -- | Variant of 'showSrcSpan' for 'RealSrcSpan's showRealSrcSpan :: RealSrcSpan -> String @@ -4235,14 +4236,14 @@ stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg mb_span <- getCurrentBreakSpan case mb_span of Nothing -> stepCmd [] - Just (UnhelpfulSpan _) -> liftIO $ putStrLn ( -- #14690 - ":steplocal is not possible." ++ - "\nCannot determine current top-level binding after " ++ - "a break on error / exception.\nUse :stepmodule.") - Just loc -> do + Just loc@(RealSrcSpan{}) -> do md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule current_toplevel_decl <- flip enclosingTickSpan loc <$> getTickArray md doContinue (GHC.LocalStep (RealSrcSpan current_toplevel_decl Strict.Nothing)) + Just _ -> liftIO $ putStrLn ( -- #14690 + ":steplocal is not possible." ++ + "\nCannot determine current top-level binding after " ++ + "a break on error / exception.\nUse :stepmodule.") stepModuleCmd :: GhciMonad m => String -> m () stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg @@ -4580,7 +4581,7 @@ listCmd "" = do printForUser $ text "Not stopped at a breakpoint; nothing to list" Just (RealSrcSpan pan _) -> listAround pan True - Just pan@(UnhelpfulSpan _) -> + Just pan@_ -> do resumes <- GHC.getResumeContext case resumes of [] -> panic "No resumes" ===================================== ghc/GHCi/UI/Info.hs ===================================== @@ -168,6 +168,7 @@ findName infos span0 mi string = Just name -> case getSrcSpan name of UnhelpfulSpan {} -> tryExternalModuleResolution + GeneratedSrcSpan {} -> tryExternalModuleResolution RealSrcSpan {} -> return (getName name) where rdrs = modInfo_rdrs mi ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -481,6 +481,7 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do dp = adjustDeltaForOffset off (ss2delta priorEndAfterComments r) Just (EpaSpan (UnhelpfulSpan r)) -> panic $ "enterAnn: UnhelpfulSpan:" ++ show r + Just (EpaSpan (GeneratedSrcSpan r)) -> panic $ "enterAnn: UnhelpfulSpan:" ++ show r when (isJust med) $ debugM $ "enterAnn:(med,edp)=" ++ showAst (med,edp) when (isJust medr) $ setExtraDPReturn medr -- --------------------------------------------- @@ -741,7 +742,7 @@ printStringAtNC el str = do printStringAtAAC :: (Monad m, Monoid w) => CaptureComments -> EpaLocation -> String -> EP w m EpaLocation printStringAtAAC capture (EpaSpan (RealSrcSpan r _)) s = printStringAtRsC capture r s -printStringAtAAC _capture (EpaSpan ss@(UnhelpfulSpan _)) _s = error $ "printStringAtAAC:ss=" ++ show ss +printStringAtAAC _capture (EpaSpan ss) _s = error $ "printStringAtAAC:ss=" ++ show ss printStringAtAAC capture (EpaDelta ss d cs) s = do mapM_ printOneComment $ concatMap tokComment cs pe1 <- getPriorEndD @@ -1360,7 +1361,7 @@ printOneComment c@(Comment _str loc _r _mo) = do let dp = ss2delta pe r debugM $ "printOneComment:(dp,pe,loc)=" ++ showGhc (dp,pe,loc) adjustDeltaForOffsetM dp - EpaSpan (UnhelpfulSpan _) -> return (SameLine 0) + EpaSpan _ -> return (SameLine 0) mep <- getExtraDP dp' <- case mep of Just (EpaDelta _ edp _) -> do ===================================== utils/check-exact/Parsers.hs ===================================== @@ -305,8 +305,6 @@ fixModuleHeaderComments (GHC.L l p) = GHC.L l p' where moveComments :: GHC.EpaLocation -> GHC.LHsDecl GHC.GhcPs -> GHC.EpAnnComments -> (GHC.LHsDecl GHC.GhcPs, GHC.EpAnnComments) - moveComments GHC.EpaDelta{} dd cs = (dd,cs) - moveComments (GHC.EpaSpan (GHC.UnhelpfulSpan _)) dd cs = (dd,cs) moveComments (GHC.EpaSpan (GHC.RealSrcSpan r _)) (GHC.L (GHC.EpAnn anc an csd) a) cs = (dd,css) where -- Move any comments on the decl that occur prior to the location @@ -318,12 +316,14 @@ fixModuleHeaderComments (GHC.L l p) = GHC.L l p' dd = GHC.L (GHC.EpAnn anc an csd') a css = cs <> GHC.EpaComments move + moveComments _ dd cs = (dd,cs) (ds',an') = rebalance (GHC.hsmodDecls p, GHC.hsmodAnn $ GHC.hsmodExt p) p' = p { GHC.hsmodExt = (GHC.hsmodExt p){ GHC.hsmodAnn = an' }, GHC.hsmodDecls = ds' } + rebalance :: ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule) -> ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule) rebalance (ds, GHC.EpAnn a an cs) = (ds1, GHC.EpAnn a an cs') ===================================== utils/check-exact/Transform.hs ===================================== @@ -255,6 +255,8 @@ setEntryDPDecl d dp = setEntryDP d dp setEntryDP :: LocatedAn t a -> DeltaPos -> LocatedAn t a setEntryDP (L (EpAnn (EpaSpan ss@(UnhelpfulSpan _)) an cs) a) dp = L (EpAnn (EpaDelta ss dp []) an cs) a +setEntryDP (L (EpAnn (EpaSpan ss@(GeneratedSrcSpan _)) an cs) a) dp + = L (EpAnn (EpaDelta ss dp []) an cs) a setEntryDP (L (EpAnn (EpaSpan ss) an (EpaComments [])) a) dp = L (EpAnn (EpaDelta ss dp []) an (EpaComments [])) a setEntryDP (L (EpAnn (EpaDelta ss d csd) an cs) a) dp @@ -320,14 +322,12 @@ getEntryDP _ = SameLine 1 addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation addEpaLocationDelta _off _anc (EpaDelta ss d cs) = EpaDelta ss d cs -addEpaLocationDelta _off _anc (EpaSpan ss@(UnhelpfulSpan _)) = EpaDelta ss (SameLine 0) [] addEpaLocationDelta off anc (EpaSpan ss@(RealSrcSpan r _)) = EpaDelta ss (adjustDeltaForOffset off (ss2deltaEnd anc r)) [] +addEpaLocationDelta _off _anc (EpaSpan ss) = EpaDelta ss (SameLine 0) [] -- Set the entry DP for an element coming after an existing keyword annotation setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t -setEntryDPFromAnchor _off (EpaDelta _ _ _) (L la a) = L la a -setEntryDPFromAnchor _off (EpaSpan (UnhelpfulSpan _)) (L la a) = L la a setEntryDPFromAnchor off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP ll dp' where dp' = case la of @@ -335,6 +335,8 @@ setEntryDPFromAnchor off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP (EpAnn (EpaSpan _) _ _) -> adjustDeltaForOffset off (SameLine 0) (EpAnn (EpaDelta _ dp _) _ _) -> adjustDeltaForOffset off dp +setEntryDPFromAnchor _off _ ll = ll + -- --------------------------------------------------------------------- -- |Take the annEntryDelta associated with the first item and @@ -902,7 +904,7 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where let off = case l of (EpaSpan (RealSrcSpan r _)) -> LayoutStartCol $ snd $ ss2pos r - (EpaSpan (UnhelpfulSpan _)) -> LayoutStartCol 0 + (EpaSpan _) -> LayoutStartCol 0 (EpaDelta _ (SameLine _) _) -> LayoutStartCol 0 (EpaDelta _ (DifferentLine _ c) _) -> LayoutStartCol c ex'' = setEntryDPFromAnchor off i ex ===================================== utils/check-exact/Utils.hs ===================================== @@ -530,9 +530,10 @@ sortEpaComments cs = sortBy cmp cs -- | Makes a comment which originates from a specific keyword. mkKWComment :: String -> NoCommentsLocation -> Comment -mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) = Comment kw (EpaSpan (RealSrcSpan ss mb)) ss (Just kw) -mkKWComment kw (EpaSpan (UnhelpfulSpan _)) = Comment kw (EpaDelta noSrcSpan (SameLine 0) NoComments) placeholderRealSpan (Just kw) mkKWComment kw (EpaDelta ss dp cs) = Comment kw (EpaDelta ss dp cs) placeholderRealSpan (Just kw) +mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) = Comment kw (EpaSpan (RealSrcSpan ss mb)) ss (Just kw) +mkKWComment kw (EpaSpan _) = Comment kw (EpaDelta noSrcSpan (SameLine 0) NoComments) placeholderRealSpan (Just kw) + sortAnchorLocated :: [GenLocated EpaLocation a] -> [GenLocated EpaLocation a] sortAnchorLocated = sortBy (compare `on` (epaLocationRealSrcSpan . getLoc)) ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs ===================================== @@ -105,10 +105,13 @@ parse parserOpts sDocContext fpath bs = case unP (go False []) initState of parsePlainTok inPrag = do (bInit, lInit) <- lift getInput L sp tok <- tryP (Lexer.lexer False return) - (bEnd, _) <- lift getInput case sp of - UnhelpfulSpan _ -> pure ([], False) -- pretend the token never existed - RealSrcSpan rsp _ -> do + RealSrcSpan rsp _ -> tryParse inPrag rsp bInit lInit sp tok + GeneratedSrcSpan (OrigSpan rsp) -> tryParse inPrag rsp bInit lInit sp tok + _ -> pure ([], False) -- pretend the token never existed + + tryParse inPrag rsp bInit lInit sp tok = do + (bEnd, _) <- lift getInput let typ = if inPrag then TkPragma else classify tok RealSrcLoc lStart _ = srcSpanStart sp -- safe since @sp@ is real (spaceBStr, bStart) = spanPosition lInit lStart bInit ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs ===================================== @@ -53,7 +53,7 @@ module Haddock.Backends.Xhtml.Utils , collapseControl ) where -import GHC (Name, SrcSpan (..), srcSpanStartLine) +import GHC (Name, SrcSpan (..), GeneratedSrcSpanDetails (..), srcSpanStartLine) import GHC.Types.Name (getOccString, isValOcc, nameOccName) import GHC.Unit.Module (Module, ModuleName, moduleName, moduleNameString) import Text.XHtml hiding (name, p, quote, title) @@ -103,6 +103,10 @@ spliceURL' maybe_mod maybe_name maybe_loc = run case span_ of RealSrcSpan span__ _ -> show $ srcSpanStartLine span__ + GeneratedSrcSpan sp -> + case sp of + OrigSpan span__ -> show $ srcSpanStartLine span__ + _ -> "" UnhelpfulSpan _ -> "" run "" = "" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/97246591adca6ce6fe1c3383e452339… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/97246591adca6ce6fe1c3383e452339… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/linker_fix] Remove now redundant thin archive special case.
by Andreas Klebinger (＠AndreasK) 20 Jan '26

20 Jan '26

Andreas Klebinger pushed to branch wip/andreask/linker_fix at Glasgow Haskell Compiler / GHC Commits: bcf76dcc by Andreas Klebinger at 2026-01-20T15:18:16+01:00 Remove now redundant thin archive special case. - - - - - 1 changed file: - rts/linker/LoadArchive.c Changes: ===================================== rts/linker/LoadArchive.c ===================================== @@ -552,9 +552,6 @@ HsInt loadArchive_ (pathchar *path) if (!readThinArchiveMember(n, memberSize, path, fileName, image)) { goto fail; } - // Unlike for regular archives for thin archives we can only identify the object format - // after having read the file pointed to. - object_fmt = identifyObjectFile_(image, memberSize); } else { View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bcf76dcc3577280023a7d57b80b8cc1… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bcf76dcc3577280023a7d57b80b8cc1… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/fendor/freeze-throw
by Hannes Siebenhandl (＠fendor) 20 Jan '26

20 Jan '26

Hannes Siebenhandl pushed new branch wip/fendor/freeze-throw at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fendor/freeze-throw You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/fendor/stack-annotation-ty
by Hannes Siebenhandl (＠fendor) 20 Jan '26

20 Jan '26

Hannes Siebenhandl pushed new branch wip/fendor/stack-annotation-ty at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fendor/stack-annotation-ty You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/24486
by Zubin (＠wz1000) 20 Jan '26

20 Jan '26

Zubin pushed new branch wip/24486 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/24486 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/ext-interp-trace-stderr
by Cheng Shao (＠TerrorJack) 20 Jan '26

20 Jan '26

Cheng Shao pushed new branch wip/ext-interp-trace-stderr at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/ext-interp-trace-stderr You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/24588] ghc-toolchain: Also configure windres on non-windows platforms.
by Zubin (＠wz1000) 20 Jan '26

20 Jan '26

Zubin pushed to branch wip/24588 at Glasgow Haskell Compiler / GHC Commits: 8620a2a6 by Zubin Duggal at 2026-01-20T18:30:12+05:30 ghc-toolchain: Also configure windres on non-windows platforms. It may be needed for cross compilation. Fixes #24588 - - - - - 1 changed file: - utils/ghc-toolchain/exe/Main.hs Changes: ===================================== utils/ghc-toolchain/exe/Main.hs ===================================== @@ -480,13 +480,8 @@ mkTarget opts = do opt <- optional $ findProgram "opt" (optOpt opts) ["opt"] llvmAs <- optional $ findProgram "llvm assembler" (optLlvmAs opts) ["clang"] - -- Windows-specific utilities - windres <- - case archOS_OS archOs of - OSMinGW32 -> do - windres <- findProgram "windres" (optWindres opts) ["windres"] - return (Just windres) - _ -> return Nothing + -- for windows, also used for cross compiling + windres <- optional $ findProgram "windres" (optWindres opts) ["windres"] -- Darwin-specific utilities (otool, installNameTool) <- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8620a2a69c3dd9ece92c86c865728aa… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8620a2a69c3dd9ece92c86c865728aa… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/26738
by Zubin (＠wz1000) 20 Jan '26

20 Jan '26

Zubin pushed new branch wip/26738 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/26738 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/24588
by Zubin (＠wz1000) 20 Jan '26

20 Jan '26

Zubin pushed new branch wip/24588 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/24588 You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/26416] DmdAnal: Don't give an absent demand signature to an argument if the argument doesn't
by Zubin (＠wz1000) 20 Jan '26

20 Jan '26

Zubin pushed to branch wip/26416 at Glasgow Haskell Compiler / GHC Commits: decf94a1 by Zubin Duggal at 2026-01-20T17:30:26+05:30 DmdAnal: Don't give an absent demand signature to an argument if the argument doesn't also have an absent demand signature in its unfolding. Otherwise, in some cases we might mark an argument as absent and generate a LitRubbish for it, but then the function might inline and turn out to actually use this argument, resulting in a run time crash. Partially addresses #26416. There may still be cases where an absent argument turns out to be used due to a rule firing. - - - - - 4 changed files: - compiler/GHC/Core/Opt/DmdAnal.hs - + testsuite/tests/dmdanal/should_run/M1.hs - + testsuite/tests/dmdanal/should_run/T26416.hs - testsuite/tests/dmdanal/should_run/all.T Changes: ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -1106,8 +1106,17 @@ dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_sd rhs DmdType rhs_env rhs_dmds = rhs_dmd_ty + + -- See Note [Absence analysis for stable unfoldings and RULES] + -- If there's a stable unfolding, we need to combine argument demands + -- from the unfolding with those from the RHS, because the unfolding + -- might use arguments that the (optimised) RHS doesn't. + -- Any argument with a demand absent in one but not the other can + -- be problematic, see #26416 + combined_rhs_dmds = combineUnfoldingDmds env rhs_sd id rhs_dmds + (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id ww_arity - rhs_dmds (de_div rhs_env) rhs' + combined_rhs_dmds (de_div rhs_env) rhs' dmd_sig_arity = ww_arity + strictCallArity body_sd sig = mkDmdSigForArity dmd_sig_arity (DmdType sig_env final_rhs_dmds) @@ -1144,6 +1153,28 @@ splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds) splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs) where (!weak_fvs, !sig_fvs) = partitionVarEnv isWeakDmd fvs +-- | If there is a stable unfolding, don't let any demand be absent that +-- is also not absent in the unfolding +-- See Note [Absence analysis for stable unfoldings and RULES], Wrinkle (W3). +combineUnfoldingDmds :: AnalEnv -> SubDemand -> Id -> [Demand] -> [Demand] +combineUnfoldingDmds env rhs_sd id rhs_dmds + | not (isStableUnfolding unf) + = rhs_dmds -- No stable unfolding, nothing to do + + | Just unf_body <- maybeUnfoldingTemplate unf + , let WithDmdType (DmdType _ unf_dmds) _ = dmdAnal env rhs_sd unf_body + , let result = go rhs_dmds unf_dmds + = -- pprTrace "lubUnfoldingDmds" (ppr id $$ ppr rhs_dmds $$ ppr unf_dmds $$ ppr result) $ + result + | otherwise = rhs_dmds + where + unf = realIdUnfolding id + go rhs [] = rhs + go [] _ = [] + go (AbsDmd:rhs) (u:unfs) = u : go rhs unfs + go (r:rhs) (AbsDmd:unfs) = r : go rhs unfs + go (r:rhs) (_:unfs) = r : go rhs unfs + -- | The result type after applying 'idArity' many arguments. Returns 'Nothing' -- when the type doesn't have exactly 'idArity' many arrows. resultType_maybe :: Id -> Maybe Type @@ -1523,6 +1554,25 @@ Wrinkles: for `sg`, failing to unleash the signature and hence observed an absent error instead of the `really important message`. + (W3) The SOLUTION above handles /free variables/ of stable unfoldings, but + what about /arguments/? Consider (#25965) + + fromVector :: (Storable a, KnownNat n) => Vector a -> Vector a + fromVector v = ... (uses Storable dictionary) ... + {-# INLINABLE fromVector #-} + + Suppose that the optimised RHS of `fromVector` somehow discards the use of + the Storable dictionary, but the stable unfolding still uses it. Then the + demand signature will say that the Storable dictionary argument is absent, + and worker/wrapper will replace it with `LitRubbish`. But when the + worker's unfolding is inlined, it will use that rubbish value as a real + dictionary, leading to a segfault! + + SOLUTION: in `dmdAnalRhsSig`, if the function has a stable unfolding, + analyse it and drop any AbsDmds which are not absent in the unfolding. + This is done by `combineUnfoldingDmds`. This ensures that if the unfolding + uses an argument, it won't be marked as absent. + Note [DmdAnal for DataCon wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We give DataCon wrappers a (necessarily flat) demand signature in @@ -2046,8 +2096,11 @@ finaliseArgBoxities env fn ww_arity arg_dmds div rhs arg_triples :: [(Type, StrictnessMark, Demand)] arg_triples = take ww_arity $ - [ (idType bndr, NotMarkedStrict, get_dmd bndr) - | bndr <- bndrs, isRuntimeVar bndr ] + zipWith mk_triple + [ bndr | bndr <- bndrs, isRuntimeVar bndr ] + arg_dmds + where + mk_triple bndr dmd = (idType bndr, NotMarkedStrict, get_dmd dmd) arg_dmds' = ww_arg_dmds ++ map trimBoxity (drop ww_arity arg_dmds) -- If ww_arity < length arg_dmds, the leftover ones @@ -2063,12 +2116,10 @@ finaliseArgBoxities env fn ww_arity arg_dmds div rhs -- This is the budget initialisation step of -- Note [Worker argument budget] - get_dmd :: Id -> Demand - get_dmd bndr + get_dmd :: Demand -> Demand + get_dmd dmd | is_bot_fn = unboxDeeplyDmd dmd -- See Note [Boxity for bottoming functions], | otherwise = dmd -- case (B) - where - dmd = idDemandInfo bndr -- is_bot_fn: see Note [Boxity for bottoming functions] is_bot_fn = div == botDiv ===================================== testsuite/tests/dmdanal/should_run/M1.hs ===================================== @@ -0,0 +1,17 @@ +-- Short module name is essential, or else f doesn't inline +module M1 where +{-# INLINABLE [2] f #-} +f :: Int -> Int -> Float +f !dummy x = if times dummy 0 x == 1 + then 3.0 else 4.0 + +{-# INLINE [0] times #-} +times :: Int -> Int -> Int -> Int +times dummy 0 x = x `seq` ( 0 + big dummy ) +times _ a b = a * b + +{-# RULES "times" [1] forall dummy x. times dummy 0 x = 0 + big dummy #-} + +big :: Int -> Int +big x = succ . succ . succ . succ . succ . succ . succ . succ . succ $ x +{-# INLINE big #-} ===================================== testsuite/tests/dmdanal/should_run/T26416.hs ===================================== @@ -0,0 +1,3 @@ +module Main where +import M1 ( f ) +main = print (f 19 12) ===================================== testsuite/tests/dmdanal/should_run/all.T ===================================== @@ -34,3 +34,4 @@ test('T22475b', normal, compile_and_run, ['']) test('T22549', normal, compile_and_run, ['-fdicts-strict -fno-specialise']) test('T23208', exit_code(1), multimod_compile_and_run, ['T23208_Lib', 'T23208']) test('T25439', normal, compile_and_run, ['']) +test('T26416', normal, compile_and_run, ['T26416','M1.hs']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/decf94a1e1c3b6486f37f32dc2a0a5b… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/decf94a1e1c3b6486f37f32dc2a0a5b… You're receiving this email because of your account on gitlab.haskell.org.

1 0