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/97246591adca6ce6fe1c3383e452339b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/97246591adca6ce6fe1c3383e452339b... You're receiving this email because of your account on gitlab.haskell.org.