Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: a10cb52a by Zubin Duggal at 2026-08-06T07:29:26-04:00 hie files: Dump the type table when dumping with -ddump-hie - - - - - a745b443 by Zubin Duggal at 2026-08-06T07:29:26-04:00 hie files: Take evidence for quantified constraints into account when saving evidence terms to the hie ast Fixes #25709 - - - - - 5f17ab12 by Simon Jakobi at 2026-08-06T07:29:28-04:00 testsuite: fix stale paths for the ghc-config build artifacts ghc-config.hs moved from testsuite/mk/ to testsuite/ghc-config/ in 6c7a49139c, but the .gitignore entry and the clean rule still referred to the old location. As a result the compiled ghc-config binary, which boilerplate.mk rebuilds on every make-driven test run, showed up as an untracked file and was never cleaned. Assisted-by: Claude Opus 5 - - - - - fecb9282 by Simon Peyton Jones at 2026-08-06T07:29:28-04:00 Documentation only ...driven by my investigation of #27591 - - - - - 1cab497c by Alan Zimmerman at 2026-08-06T07:29:29-04:00 EPA: Replace AnnPragma with individual types We introduced AnnPragma as a common type for all pragma usages wrapped in LocatedP / SrcSpanAnnP. Now that those are gone, and the AnnPragma moved into the TTG points for the given items, we can ensure that each carries only the annotations it needs. So we remove AnnPragma, and in its place bring in AnnCType AnnWarningTxt AnnOverlap AnnAnnDecl AnnPragSCC - - - - - 20 changed files: - compiler/GHC/Core/Class.hs - compiler/GHC/Driver/Main/Passes.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Decls/Overlap.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Iface/Ext/Types.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Rename/HsType.hs - compiler/GHC/Types/ForeignCall.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Unit/Module/Warnings.hs - testsuite/.gitignore - testsuite/Makefile - testsuite/tests/hiefile/should_compile/T24493.stderr - + testsuite/tests/hiefile/should_run/T25709.hs - + testsuite/tests/hiefile/should_run/T25709.stdout - testsuite/tests/hiefile/should_run/all.T - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== compiler/GHC/Core/Class.hs ===================================== @@ -84,9 +84,9 @@ data Class -- Here fun-deps are [([a,b],[c]), ([a,c],[b])] type FunDep a = ([a],[a]) -type ClassOpItem = (Id, DefMethInfo) - -- Selector function; contains unfolding - -- Default-method info +type ClassOpItem = ( Id -- Dictionary selector function + -- See Note [Dictionary selectors] + , DefMethInfo) -- Default-method info type DefMethInfo = Maybe (Name, DefMethSpec Type) -- Nothing No default method @@ -164,7 +164,19 @@ classMinimalDef :: Class -> ClassMinimalDef classMinimalDef Class{ classBody = ConcreteClass{ cls_min_def = d } } = d classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction -{- +{- Note [Dictionary selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each `ClassOpItem` stores a dictionary selector `Id`: + +* The type of the selector is always closed, and has form + forall a1..an. C a1 .. an => blah + where `a1..an` are the class variables, and + `blah` is the method type. + See GHC.Types.Id.Make.mkDictSelId, which constructs them. + +* The selector has no unfolding, but one RULE. + See Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance + Note [Associated type defaults] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The following is an example of associated type defaults: ===================================== compiler/GHC/Driver/Main/Passes.hs ===================================== @@ -92,7 +92,7 @@ import GHC.Iface.Make import GHC.Iface.Recomp import GHC.Iface.Tidy import GHC.Iface.Ext.Ast ( mkHieFile ) -import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module ) +import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module, hie_types ) import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result) import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) @@ -167,7 +167,7 @@ import GHC.Data.StringBuffer import GHC.Data.Maybe import qualified GHC.Data.Strict as Strict - +import qualified Data.Array as A import Data.List ( nub, isPrefixOf, partition ) import qualified Data.List.NonEmpty as NE import Control.Monad @@ -332,7 +332,10 @@ extract_renamed_stuff mod_summary tc_result = do hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info) let out_file = ml_hie_file $ ms_location mod_summary liftIO $ writeHieFile out_file hieFile - liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) + let hie_doc = + ppr (hie_asts hieFile) + $+$ ppr (A.assocs $ hie_types hieFile) + liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell hie_doc -- Validate HIE files when (gopt Opt_ValidateHie dflags) $ do ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -1528,7 +1528,7 @@ instance OutputableBndrId p ************************************************************************ -} -type instance XHsAnnotation (GhcPass _) = (AnnPragma, SourceText) +type instance XHsAnnotation (GhcPass _) = (AnnAnnDecl, SourceText) type instance XXAnnDecl (GhcPass _) = DataConCantHappen instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where ===================================== compiler/GHC/Hs/Decls/Overlap.hs ===================================== @@ -26,7 +26,7 @@ import GHC.Prelude import GHC.Hs.Extension -import GHC.Parser.Annotation ( AnnPragma ) +import GHC.Parser.Annotation ( AnnOverlap ) import Language.Haskell.Syntax.Decls.Overlap import Language.Haskell.Syntax.Extension @@ -67,8 +67,8 @@ instance NFData OverlapFlag where instance Outputable OverlapFlag where ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) -type instance XOverlapMode GhcPs = (SourceText, AnnPragma) -type instance XOverlapMode GhcRn = (SourceText, AnnPragma) +type instance XOverlapMode GhcPs = (SourceText, AnnOverlap) +type instance XOverlapMode GhcRn = (SourceText, AnnOverlap) type instance XOverlapMode GhcTc = SourceText type instance XXOverlapMode (GhcPass _) = DataConCantHappen ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -612,7 +612,7 @@ instance NoAnn AnnFunRhs where -- --------------------------------------------------------------------- -type instance XSCC (GhcPass _) = (AnnPragma, SourceText) +type instance XSCC (GhcPass _) = (AnnPragSCC, SourceText) type instance XXPragE (GhcPass _) = DataConCantHappen type instance XCDotFieldOcc (GhcPass _) = AnnFieldLabel ===================================== compiler/GHC/Iface/Ext/Types.hs ===================================== @@ -159,6 +159,18 @@ data HieType a | HCoercionTy deriving (Functor, Foldable, Traversable, Eq) +instance Outputable a => Outputable (HieType a) where + ppr (HTyVarTy name) = ppr name + ppr (HAppTy fun arg) = parens $ ppr fun <+> ppr arg + ppr (HTyConApp tc args) = parens $ ppr tc <+> ppr args + ppr (HForAllTy ((name, ty), flag) body) = + text "forall" <+> ppr flag <+> ppr name O.<> text ":" <+> ppr ty O.<> text "." <+> ppr body + ppr (HFunTy mult arg res) = parens $ ppr arg <+> arrow <+> ppr res <+> ppr mult + ppr (HQualTy ctxt ty) = parens $ ppr ctxt <+> text "=>" <+> ppr ty + ppr (HLitTy lit) = ppr lit + ppr (HCastTy ty) = text "cast" <+> ppr ty + ppr HCoercionTy = text "<coercion>" + type HieTypeFlat = HieType TypeIndex -- | Roughly isomorphic to the original core 'Type'. @@ -222,6 +234,10 @@ instance Binary (HieArgs TypeIndex) where put_ bh (HieArgs xs) = put_ bh xs get bh = HieArgs <$> get bh +instance Outputable a => Outputable (HieArgs a) where + ppr (HieArgs args) = braces $ hsep $ punctuate comma $ map pprArg args + where pprArg (vis, ty) = (if vis then id else parens) (ppr ty) + -- A HiePath is just a lexical FastString. We use a lexical FastString to avoid -- non-determinism when printing or storing HieASTs which are sorted by their ===================================== compiler/GHC/Parser.y ===================================== @@ -1473,13 +1473,13 @@ inst_decl :: { LInstDecl GhcPs } overlap_pragma :: { Maybe (LocatedA (OverlapMode GhcPs)) } : '{-# OVERLAPPABLE' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1, - AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) } + AnnOverlap (glR $1) (epTok $2)))) } | '{-# OVERLAPPING' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1, - AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) } + AnnOverlap (glR $1) (epTok $2)))) } | '{-# OVERLAPS' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1, - AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) } + AnnOverlap (glR $1) (epTok $2)))) } | '{-# INCOHERENT' '#-}' {% fmap Just $ amsA' (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1, - AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn))) } + AnnOverlap (glR $1) (epTok $2)))) } | {- empty -} { Nothing } deriv_strategy_no_via :: { LDerivStrategy GhcPs } @@ -1710,13 +1710,13 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs capi_ctype :: { Maybe (LocatedA (CType GhcPs)) } capi_ctype : '{-# CTYPE' STRING STRING '#-}' {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $3) - (AnnPragma (glR $1) (epTok $4) noAnn (glR $2) (glR $3) noAnn noAnn) + (AnnCType (glR $1) (epTok $4) (glR $2) (glR $3)) (Just (Header (getSTRINGs $2) (getSTRING $2))) (getSTRING $3)))} | '{-# CTYPE' STRING '#-}' {% fmap Just $ amsA' (sLL $1 $> (mkCType (getCTYPEs $1) (getSTRINGs $2) - (AnnPragma (glR $1) (epTok $3) noAnn noAnn (glR $2) noAnn noAnn) + (AnnCType (glR $1) (epTok $3) noAnn (glR $2)) Nothing (getSTRING $2)))} | { Nothing } @@ -2078,11 +2078,11 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated. maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) } : '{-# DEPRECATED' strings '#-}' {% fmap Just $ amsA' (sLL $1 $> $ - DeprecatedTxt (getDEPRECATED_PRAGs $1, AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) + DeprecatedTxt (getDEPRECATED_PRAGs $1, AnnWarningTxt (glR $1) (epTok $3) (fst $ unLoc $2)) (snd $ unLoc $2))} | '{-# WARNING' warning_category strings '#-}' {% fmap Just $ amsA' (sLL $1 $> $ - WarningTxt (getWARNING_PRAGs $1, AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn) + WarningTxt (getWARNING_PRAGs $1, AnnWarningTxt (glR $1) (epTok $4) (fst $ unLoc $3)) $2 (snd $ unLoc $3))} | {- empty -} { Nothing } @@ -2165,19 +2165,19 @@ stringlist :: { Located (OrdList (LocatedA (WithHsDocIdentifiers (StringLiteral annotation :: { LHsDecl GhcPs } : '{-# ANN' name_var aexp '#-}' {% runPV (unECP $3) >>= \ $3 -> amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation - (AnnPragma (glR $1) (epTok $4) noAnn noAnn noAnn noAnn noAnn, + (AnnAnnDecl (glR $1) (epTok $4) noAnn noAnn, (getANN_PRAGs $1)) (ValueAnnProvenance $2) $3)) } | '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 -> amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation - (AnnPragma (glR $1) (epTok $5) noAnn noAnn noAnn (epTok $2) noAnn, + (AnnAnnDecl (glR $1) (epTok $5) (epTok $2) noAnn, (getANN_PRAGs $1)) (TypeAnnProvenance $3) $4)) } | '{-# ANN' 'module' aexp '#-}' {% runPV (unECP $3) >>= \ $3 -> amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation - (AnnPragma (glR $1) (epTok $4) noAnn noAnn noAnn noAnn (epTok $2), + (AnnAnnDecl (glR $1) (epTok $4) noAnn (epTok $2), (getANN_PRAGs $1)) ModuleAnnProvenance $3)) } @@ -3052,12 +3052,12 @@ prag_e :: { Located (HsPragE GhcPs) } : '{-# SCC' STRING '#-}' {% do { scc <- getSCC $2 ; return (sLL $1 $> (HsPragSCC - (AnnPragma (glR $1) (epTok $3) noAnn (glR $2) noAnn noAnn noAnn, + (AnnPragSCC (glR $1) (epTok $3) (glR $2), (getSCC_PRAGs $1)) (StringLiteral (getSTRINGs $2) scc)))} } | '{-# SCC' VARID '#-}' { sLL $1 $> (HsPragSCC - (AnnPragma (glR $1) (epTok $3) noAnn (glR $2) noAnn noAnn noAnn, + (AnnPragSCC (glR $1) (epTok $3) (glR $2), (getSCC_PRAGs $1)) (StringLiteral NoSourceText (fastStringToShortText $ getVARID $2))) } ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -36,7 +36,7 @@ module GHC.Parser.Annotation ( AnnList(..), AnnListBrackets(..), AnnParen(..), - AnnPragma(..), + AnnCType(..),AnnWarningTxt(..),AnnOverlap(..),AnnAnnDecl(..),AnnPragSCC(..), AnnBooleanFormula(..), NameAnn(..), NameAdornment(..), NoEpAnns(..), @@ -627,15 +627,40 @@ data NameAdornment -- | exact print annotation used for capturing the locations of -- annotations in pragmas. -data AnnPragma - = AnnPragma { - apr_open :: EpaLocation, - apr_close :: EpToken "#-}", - apr_squares :: (EpToken "[", EpToken "]"), - apr_loc1 :: EpaLocation, - apr_loc2 :: EpaLocation, - apr_type :: EpToken "type", - apr_module :: EpToken "module" +data AnnCType + = AnnCType { + ac_open :: EpaLocation, + ac_close :: EpToken "#-}", + ac_loc1 :: EpaLocation, + ac_loc2 :: EpaLocation + } deriving (Data,Eq) + +data AnnWarningTxt + = AnnWarningTxt { + awt_open :: EpaLocation, + awt_close :: EpToken "#-}", + awt_squares :: (EpToken "[", EpToken "]") + } deriving (Data,Eq) + +data AnnOverlap + = AnnOverlap { + ao_open :: EpaLocation, + ao_close :: EpToken "#-}" + } deriving (Data,Eq) + +data AnnAnnDecl + = AnnAnnDecl { + ad_open :: EpaLocation, + ad_close :: EpToken "#-}", + ad_type :: EpToken "type", + ad_module :: EpToken "module" + } deriving (Data,Eq) + +data AnnPragSCC + = AnnPragSCC { + aps_open :: EpaLocation, + aps_close :: EpToken "#-}", + aps_loc1 :: EpaLocation } deriving (Data,Eq) -- --------------------------------------------------------------------- @@ -1020,8 +1045,20 @@ instance NoAnn a => NoAnn (AnnList a) where instance NoAnn NameAnn where noAnn = NameAnnTrailing [] -instance NoAnn AnnPragma where - noAnn = AnnPragma noAnn noAnn noAnn noAnn noAnn noAnn noAnn +instance NoAnn AnnCType where + noAnn = AnnCType noAnn noAnn noAnn noAnn + +instance NoAnn AnnWarningTxt where + noAnn = AnnWarningTxt noAnn noAnn noAnn + +instance NoAnn AnnOverlap where + noAnn = AnnOverlap noAnn noAnn + +instance NoAnn AnnAnnDecl where + noAnn = AnnAnnDecl noAnn noAnn noAnn noAnn + +instance NoAnn AnnPragSCC where + noAnn = AnnPragSCC noAnn noAnn noAnn instance NoAnn AnnParen where noAnn = AnnParens noAnn noAnn @@ -1107,7 +1144,23 @@ instance Outputable AnnListBrackets where ppr (ListBanana o c) = text "ListBanana" <+> ppr o <+> ppr c ppr ListNone = text "ListNone" -instance Outputable AnnPragma where - ppr (AnnPragma o c s l ca t m) - = text "AnnPragma" <+> ppr o <+> ppr c <+> ppr s <+> ppr l - <+> ppr ca <+> ppr ca <+> ppr t <+> ppr m +instance Outputable AnnCType where + ppr (AnnCType o c l ca) + = text "AnnCType" <+> ppr o <+> ppr c <+> ppr l + <+> ppr ca <+> ppr ca + +instance Outputable AnnWarningTxt where + ppr (AnnWarningTxt o c s) + = text "AnnWarningTxt" <+> ppr o <+> ppr c <+> ppr s + +instance Outputable AnnOverlap where + ppr (AnnOverlap o c) + = text "AnnOverlap" <+> ppr o <+> ppr c + +instance Outputable AnnAnnDecl where + ppr (AnnAnnDecl o c t m) + = text "AnnAnnDecl" <+> ppr o <+> ppr c <+> ppr t <+> ppr m + +instance Outputable AnnPragSCC where + ppr (AnnPragSCC o c l) + = text "AnnPragSCC" <+> ppr o <+> ppr c <+> ppr l ===================================== compiler/GHC/Rename/HsType.hs ===================================== @@ -1188,10 +1188,20 @@ bindHsOuterTyVarBndrs :: OutputableBndrFlag flag 'Renamed -> RnM (a, FreeNames) bindHsOuterTyVarBndrs doc mb_cls implicit_vars outer_bndrs thing_inside = case outer_bndrs of + HsOuterImplicit{} -> + -- Add an implicit `forall a1..an` at the top, where `a1..an` + -- are not-otherwise-in-scope type variables. + -- Used when there is no forall, or a /visible/ (forall a -> blah) + -- See Note [forall-or-nothing rule] in Language.Haskell.Syntax.Type rnImplicitTvOccs mb_cls implicit_vars $ \implicit_vars' -> thing_inside $ HsOuterImplicit { hso_ximplicit = implicit_vars' } + HsOuterExplicit{hso_bndrs = exp_bndrs} -> + -- The type already has an explicit, user-written, invisible forall, + -- so do not add an implicit forall + -- See Note [forall-or-nothing rule] in Language.Haskell.Syntax.Type + -- -- Note: If we pass mb_cls instead of Nothing below, bindLHsTyVarBndrs -- will use class variables for any names the user meant to bring in -- scope here. This is an explicit forall, so we want fresh names, not ===================================== compiler/GHC/Types/ForeignCall.hs ===================================== @@ -109,7 +109,7 @@ import Data.Data (Data) import Data.Functor ((<&>)) import Control.DeepSeq (NFData(..)) -import GHC.Parser.Annotation (AnnPragma, noAnn) +import GHC.Parser.Annotation (AnnCType, noAnn) {- ************************************************************************ @@ -216,7 +216,7 @@ defaultCType :: String -> CType (GhcPass p) defaultCType = CType (CTypeGhc NoSourceText NoSourceText noAnn) Nothing . packHText -mkCType :: SourceText -> SourceText -> AnnPragma -> Maybe (Header (GhcPass p)) -> HText -> CType (GhcPass p) +mkCType :: SourceText -> SourceText -> AnnCType -> Maybe (Header (GhcPass p)) -> HText -> CType (GhcPass p) mkCType x y ann m = CType (CTypeGhc x y ann) m @@ -303,7 +303,7 @@ data StaticTargetGhc = StaticTargetGhc data CTypeGhc = CTypeGhc { cTypeSourceText :: SourceText , cTypeOtherText :: SourceText - , cTypeAnn :: AnnPragma + , cTypeAnn :: AnnCType } deriving (Data, Eq) ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -480,7 +480,7 @@ Therefore there is no loss of generality if we make all selectors unrestricted. mkDictSelId :: Name -- Name of one of the *value* selectors -- (dictionary superclass or method) -> Class -> Id --- Important: see Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance +-- See Note [Dictionary selectors] mkDictSelId name clas = mkGlobalId (ClassOpId clas terminating) name sel_ty info where ===================================== compiler/GHC/Unit/Module/Warnings.hs ===================================== @@ -158,8 +158,8 @@ warningTxtSame w1 w2 instance Outputable (InWarningCategory (GhcPass pass)) where ppr (InWarningCategory _ wt) = text "in" <+> doubleQuotes (ppr wt) -type instance XDeprecatedTxt (GhcPass _) = (SourceText, AnnPragma) -type instance XWarningTxt (GhcPass _) = (SourceText, AnnPragma) +type instance XDeprecatedTxt (GhcPass _) = (SourceText, AnnWarningTxt) +type instance XWarningTxt (GhcPass _) = (SourceText, AnnWarningTxt) type instance XXWarningTxt (GhcPass _) = DataConCantHappen type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText) type instance XXInWarningCategory (GhcPass _) = DataConCantHappen ===================================== testsuite/.gitignore ===================================== @@ -72,7 +72,7 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk # NOTE: to edit this section in Vim, add your ignore annotations some where # in the list, select the entire section and say ':sort u' to sort it. -/mk/ghc-config +/ghc-config/ghc-config /tests/ado/ado001 /tests/annotations/should_compile/th/build_make ===================================== testsuite/Makefile ===================================== @@ -46,5 +46,6 @@ clean distclean maintainer-clean: $(RM) -f mk/*.o $(RM) -f mk/*.hi $(RM) -f mk/ghcconfig*.mk - $(RM) -f mk/ghc-config mk/ghc-config.exe + $(RM) -f ghc-config/ghc-config ghc-config/ghc-config.exe + $(RM) -f ghc-config/ghc-config.o ghc-config/ghc-config.hi $(RM) -f driver/*.pyc ===================================== testsuite/tests/hiefile/should_compile/T24493.stderr ===================================== @@ -1,3 +1,4 @@ + ==================== HIE AST ==================== File: T24493.hs Node@T24493.hs:(1,8)-(3,8): Source: From source @@ -25,9 +26,10 @@ Node@T24493.hs:(1,8)-(3,8): Source: From source Node@T24493.hs:3:6-8: Source: From source {(annotations: {(HsLit, HsExpr)}), (types: [0]), (identifier info: {})} - + +[(0, (GHC.Internal.Base.String {}))] Got valid scopes -Got no roundtrip errors \ No newline at end of file +Got no roundtrip errors ===================================== testsuite/tests/hiefile/should_run/T25709.hs ===================================== @@ -0,0 +1,40 @@ +{-# LANGUAGE QuantifiedConstraints#-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +module Main where + +import TestUtils +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Data.Either +import Data.Maybe +import Data.Bifunctor (first) +import GHC.Plugins (moduleNameString, nameStableString, nameOccName, occNameString, isDerivedOccName) +import GHC.Iface.Ext.Types + + +import Data.Typeable + +data Some c where + Some :: c a => a -> Some c + +extractSome :: (Typeable a, forall x. c x => Typeable x) => Some c -> Maybe a +extractSome (Some a) = cast a + +f :: (forall x. Ord x => Eq [x]) => () +f = () +{-# NOINLINE f #-} + +g :: () +g = f + +useQC :: forall c a. (c a, forall x. c x => Show x) => a -> String +useQC x = show x + +points :: [(Int,Int)] +points = [(22,26),(29, 5), (32, 13)] + +main = do + (df, hf) <- readTestHie "T25709.hie" + let refmap = generateReferencesMap $ getAsts $ hie_asts hf + traverse (explainEv df hf refmap) points ===================================== testsuite/tests/hiefile/should_run/T25709.stdout ===================================== @@ -0,0 +1,110 @@ +========================== +At point (22,26), we found: +========================== +┌ +│ $dTypeable at T25709.hs:22:14-19, of type: Typeable a +│ is an evidence variable bound by a let, depending on: [$dTypeable] +│ with scope: LocalScope T25709.hs:22:14-29 +│ +│ Defined at <no location info> +└ +| +`- ┌ + │ $dTypeable at T25709.hs:22:1-29, of type: Typeable a + │ is an evidence variable bound by a HsWrapper + │ with scope: LocalScope T25709.hs:22:1-29 + │ bound at: T25709.hs:22:1-29 + │ Defined at <no location info> + └ + +┌ +│ $dTypeable at T25709.hs:22:14-19, of type: Typeable a +│ is an evidence variable bound by a let, depending on: [df, irred] +│ with scope: LocalScope T25709.hs:22:14-29 +│ +│ Defined at <no location info> +└ +| ++- ┌ +| │ df at T25709.hs:22:1-29, of type: forall x. c x => Typeable x +| │ is an evidence variable bound by a HsWrapper +| │ with scope: LocalScope T25709.hs:22:1-29 +| │ bound at: T25709.hs:22:1-29 +| │ Defined at <no location info> +| └ +| +`- ┌ + │ irred at T25709.hs:22:14-19, of type: c a + │ is an evidence variable bound by a let, depending on: [irred] + │ with scope: LocalScope T25709.hs:22:14-29 + │ + │ Defined at <no location info> + └ + | + `- ┌ + │ irred at T25709.hs:22:14-19, of type: c a + │ is an evidence variable bound by a pattern + │ with scope: LocalScope T25709.hs:22:14-29 + │ + │ Defined at <no location info> + └ + +========================== +At point (29,5), we found: +========================== +┌ +│ df at T25709.hs:1:1, of type: forall x. Ord x => Eq [x] +│ is an evidence variable bound by a let, depending on: [$p1Ord, +│ $fEqList] +│ with scope: ModuleScope +│ +│ Defined at <no location info> +└ +| ++- ┌ +| │ $p1Ord at T25709.hs:1:1, of type: forall a. Ord a => Eq a +| │ is a usage of an external evidence variable +| │ Defined in `GHC.Internal.Classes' +| └ +| +`- ┌ + │ $fEqList at T25709.hs:1:1, of type: forall a. Eq a => Eq [a] + │ is a usage of an external evidence variable + │ Defined in `GHC.Internal.Classes' + └ + +========================== +At point (32,13), we found: +========================== +┌ +│ $dShow at T25709.hs:32:1-16, of type: Show a +│ is an evidence variable bound by a let, depending on: [df, irred] +│ with scope: LocalScope T25709.hs:32:1-16 +│ bound at: T25709.hs:32:1-16 +│ Defined at <no location info> +└ +| ++- ┌ +| │ df at T25709.hs:32:1-16, of type: forall x. c x => Show x +| │ is an evidence variable bound by a HsWrapper +| │ with scope: LocalScope T25709.hs:32:1-16 +| │ bound at: T25709.hs:32:1-16 +| │ Defined at <no location info> +| └ +| +`- ┌ + │ irred at T25709.hs:32:1-16, of type: c a + │ is an evidence variable bound by a let, depending on: [irred] + │ with scope: LocalScope T25709.hs:32:1-16 + │ bound at: T25709.hs:32:1-16 + │ Defined at <no location info> + └ + | + `- ┌ + │ irred at T25709.hs:32:1-16, of type: c a + │ is an evidence variable bound by a HsWrapper + │ with scope: LocalScope T25709.hs:32:1-16 + │ bound at: T25709.hs:32:1-16 + │ Defined at <no location info> + └ + ===================================== testsuite/tests/hiefile/should_run/all.T ===================================== @@ -8,4 +8,5 @@ test('HieVdq', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUti test('T23540', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) test('T23120', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) test('T24544', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) -test('HieGadtConSigs', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) \ No newline at end of file +test('HieGadtConSigs', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) +test('T25709', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info']) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -288,10 +288,6 @@ instance HasTrailing [TrailingAnn] where trailing a = a setTrailing _ ts = ts -instance HasTrailing AnnPragma where - trailing _ = [] - setTrailing a _ = a - instance HasTrailing AnnParen where trailing _ = [] setTrailing a _ = a @@ -1559,22 +1555,22 @@ instance ExactPrint (WarningTxt GhcPs) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (WarningTxt (src, AnnPragma o c (os,cs) l1 l2 t m) mb_cat ws) = do + exact (WarningTxt (src, AnnWarningTxt o c (os,cs)) mb_cat ws) = do o' <- markAnnOpen'' o src "{-# WARNING" mb_cat' <- markAnnotated mb_cat os' <- markEpToken os ws' <- mapM markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c - return (WarningTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) mb_cat' ws') + return (WarningTxt (src, AnnWarningTxt o' c' (os',cs')) mb_cat' ws') - exact (DeprecatedTxt (src, AnnPragma o c (os,cs) l1 l2 t m) ws) = do + exact (DeprecatedTxt (src, AnnWarningTxt o c (os,cs)) ws) = do o' <- markAnnOpen'' o src "{-# DEPRECATED" os' <- markEpToken os ws' <- mapM markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c - return (DeprecatedTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) ws') + return (DeprecatedTxt (src, AnnWarningTxt o' c' (os',cs')) ws') instance ExactPrint (InWarningCategory GhcPs) where getAnnotationEntry _ = NoEntryVal @@ -2251,35 +2247,35 @@ instance ExactPrint (OverlapMode GhcPs) where setAnnotationAnchor a _ _ _ = a -- NOTE: NoOverlap is only used in the typechecker - exact (NoOverlap (src, AnnPragma o c s l1 l2 t m)) = do + exact (NoOverlap (src, AnnOverlap o c)) = do o' <- markAnnOpen'' o src "{-# NO_OVERLAP" c' <- markEpToken c - return (NoOverlap (src, AnnPragma o' c' s l1 l2 t m)) + return (NoOverlap (src, AnnOverlap o' c')) - exact (Overlappable (src, AnnPragma o c s l1 l2 t m)) = do + exact (Overlappable (src, AnnOverlap o c)) = do o' <- markAnnOpen'' o src "{-# OVERLAPPABLE" c' <- markEpToken c - return (Overlappable (src, AnnPragma o' c' s l1 l2 t m)) + return (Overlappable (src, AnnOverlap o' c')) - exact (Overlapping (src, AnnPragma o c s l1 l2 t m)) = do + exact (Overlapping (src, AnnOverlap o c)) = do o' <- markAnnOpen'' o src "{-# OVERLAPPING" c' <- markEpToken c - return (Overlapping (src, AnnPragma o' c' s l1 l2 t m)) + return (Overlapping (src, AnnOverlap o' c')) - exact (Overlaps (src, AnnPragma o c s l1 l2 t m)) = do + exact (Overlaps (src, AnnOverlap o c)) = do o' <- markAnnOpen'' o src "{-# OVERLAPS" c' <- markEpToken c - return (Overlaps (src, AnnPragma o' c' s l1 l2 t m)) + return (Overlaps (src, AnnOverlap o' c')) - exact (Incoherent (src, AnnPragma o c s l1 l2 t m)) = do + exact (Incoherent (src, AnnOverlap o c)) = do o' <- markAnnOpen'' o src "{-# INCOHERENT" c' <- markEpToken c - return (Incoherent (src, AnnPragma o' c' s l1 l2 t m)) + return (Incoherent (src, AnnOverlap o' c')) - exact (NonCanonical (src, AnnPragma o c s l1 l2 t m)) = do + exact (NonCanonical (src, AnnOverlap o c)) = do o' <- markAnnOpen'' o src "{-# INCOHERENT" c' <- markEpToken c - return (Incoherent (src, AnnPragma o' c' s l1 l2 t m)) + return (Incoherent (src, AnnOverlap o' c')) -- --------------------------------------------------------------------- @@ -2706,7 +2702,7 @@ instance ExactPrint (AnnDecl GhcPs) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (HsAnnotation (AnnPragma o c s l1 l2 t m, src) prov e) = do + exact (HsAnnotation (AnnAnnDecl o c t m, src) prov e) = do o' <- markAnnOpen'' o src "{-# ANN" (t', m', prov') <- case prov of @@ -2723,7 +2719,7 @@ instance ExactPrint (AnnDecl GhcPs) where e' <- markAnnotated e c' <- markEpToken c - return (HsAnnotation (AnnPragma o' c' s l1 l2 t' m',src) prov' e') + return (HsAnnotation (AnnAnnDecl o' c' t' m',src) prov' e') -- --------------------------------------------------------------------- @@ -3146,11 +3142,11 @@ instance ExactPrint (HsPragE GhcPs) where getAnnotationEntry HsPragSCC{} = NoEntryVal setAnnotationAnchor a _ _ _ = a - exact (HsPragSCC (AnnPragma o c s l1 l2 t m,st) sl) = do + exact (HsPragSCC (AnnPragSCC o c l1,st) sl) = do o' <- markAnnOpen'' o st "{-# SCC" l1' <- printStringAtAA l1 (sourceTextToString (stringLitSourceText sl) (unpackHText $ sl_fs sl)) c' <- markEpToken c - return (HsPragSCC (AnnPragma o' c' s l1' l2 t m,st) sl) + return (HsPragSCC (AnnPragSCC o' c' l1',st) sl) instance ExactPrint (HsTypedSplice GhcPs) where getAnnotationEntry _ = NoEntryVal @@ -4408,7 +4404,7 @@ instance Typeable p => ExactPrint (CType (GhcPass p)) where exact (CType ext mh ct) = do let stp = cTypeSourceText ext stct = cTypeOtherText ext - AnnPragma o c s l1 l2 t m = cTypeAnn ext + AnnCType o c l1 l2 = cTypeAnn ext o' <- markAnnOpen'' o stp "{-# CTYPE" l1' <- case mh of Nothing -> return l1 @@ -4416,7 +4412,7 @@ instance Typeable p => ExactPrint (CType (GhcPass p)) where printStringAtAA l1 (toSourceTextWithSuffix srcH "" "") l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackHText ct) "") c' <- markEpToken c - return (CType (ext { cTypeAnn = AnnPragma o' c' s l1' l2' t m }) mh ct) + return (CType (ext { cTypeAnn = AnnCType o' c' l1' l2' }) mh ct) -- --------------------------------------------------------------------- ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -838,7 +838,7 @@ type instance Anno (HsSigType DocNameI) = SrcSpanAnnA type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnBF type instance Anno (OverlapMode DocNameI) = SrcSpanAnnA type instance Anno (CType DocNameI) = SrcSpanAnnA -type instance Anno (Header DocNameI) = EpAnn AnnPragma +type instance Anno (Header DocNameI) = SrcSpanAnnA type instance Anno (HsModifierOf (LocatedA (HsType DocNameI)) DocNameI) = SrcSpanAnnA type instance Anno (HsContextDetails DocNameI a) = SrcSpanAnnA View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/528b0d8a5e58b3a5ef84f5e184f89e6... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/528b0d8a5e58b3a5ef84f5e184f89e6... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help