Vladislav Zavialov pushed to branch wip/int-index/t26418 at Glasgow Haskell Compiler / GHC Commits: 116a6a9e by Vladislav Zavialov at 2025-09-19T15:19:24+03:00 Fix keyword in ExplicitNamespaces error message (#26418) Consider this module header and the resulting error: {-# LANGUAGE NoExplicitNamespaces #-} module T26418 (data HeadC) where -- error: [GHC-47007] -- Illegal keyword 'type' Previously, the error message would mention 'type' (as shown above), even though the user wrote 'data'. This has now been fixed. The error location has also been corrected: it is now reported at the keyword position rather than at the position of the associated import/export item. - - - - - 9 changed files: - compiler/GHC/Parser.y - compiler/GHC/Parser/Errors/Ppr.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/Types.hs - testsuite/tests/parser/should_fail/T16270h.stderr - + testsuite/tests/parser/should_fail/T26418.hs - + testsuite/tests/parser/should_fail/T26418.stderr - testsuite/tests/parser/should_fail/all.T Changes: ===================================== compiler/GHC/Parser.y ===================================== @@ -1078,11 +1078,11 @@ qcname_ext_w_wildcard :: { LocatedA ImpExpQcSpec } | '..' { sL1a $1 (ImpExpQcWildcard (epTok $1) NoEpTok) } qcname_ext :: { LocatedA ImpExpQcSpec } - : qcname { sL1a $1 (ImpExpQcName $1) } - | 'type' oqtycon {% do { n <- mkTypeImpExp $2 - ; return $ sLLa $1 $> (ImpExpQcType (epTok $1) n) }} - | 'data' qvarcon {% do { n <- mkDataImpExp $2 - ; return $ sLLa $1 $> (ImpExpQcData (epTok $1) n) }} + : qcname { sL1a $1 (mkPlainImpExp $1) } + | 'type' oqtycon {% do { imp_exp <- mkTypeImpExp (epTok $1) $2 + ; return $ sLLa $1 $> imp_exp }} + | 'data' qvarcon {% do { imp_exp <- mkDataImpExp (epTok $1) $2 + ; return $ sLLa $1 $> imp_exp }} qcname :: { LocatedN RdrName } -- Variable or type constructor : qvar { $1 } -- Things which look like functions ===================================== compiler/GHC/Parser/Errors/Ppr.hs ===================================== @@ -273,9 +273,14 @@ instance Diagnostic PsMessage where 2 (pprWithCommas ppr vs) , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ] - PsErrIllegalExplicitNamespace + PsErrIllegalExplicitNamespace kw -> mkSimpleDecorated $ - text "Illegal keyword 'type'" + text "Illegal keyword" <+> quotes kw_doc + where + kw_doc = case kw of + ExplicitTypeNamespace{} -> text "type" + ExplicitDataNamespace{} -> text "data" + PsErrUnallowedPragma prag -> mkSimpleDecorated $ @@ -619,7 +624,7 @@ instance Diagnostic PsMessage where PsErrNoSingleWhereBindInPatSynDecl{} -> ErrorWithoutFlag PsErrDeclSpliceNotAtTopLevel{} -> ErrorWithoutFlag PsErrMultipleNamesInStandaloneKindSignature{} -> ErrorWithoutFlag - PsErrIllegalExplicitNamespace -> ErrorWithoutFlag + PsErrIllegalExplicitNamespace{} -> ErrorWithoutFlag PsErrUnallowedPragma{} -> ErrorWithoutFlag PsErrImportPostQualified -> ErrorWithoutFlag PsErrImportQualifiedTwice -> ErrorWithoutFlag @@ -759,7 +764,7 @@ instance Diagnostic PsMessage where PsErrNoSingleWhereBindInPatSynDecl{} -> noHints PsErrDeclSpliceNotAtTopLevel{} -> noHints PsErrMultipleNamesInStandaloneKindSignature{} -> noHints - PsErrIllegalExplicitNamespace -> [suggestExtension LangExt.ExplicitNamespaces] + PsErrIllegalExplicitNamespace{} -> [suggestExtension LangExt.ExplicitNamespaces] PsErrUnallowedPragma{} -> noHints PsErrImportPostQualified -> [suggestExtension LangExt.ImportQualifiedPost] PsErrImportQualifiedTwice -> noHints ===================================== compiler/GHC/Parser/Errors/Types.hs ===================================== @@ -214,7 +214,7 @@ data PsMessage | PsErrImportPostQualified -- | Explicit namespace keyword without 'ExplicitNamespaces' - | PsErrIllegalExplicitNamespace + | PsErrIllegalExplicitNamespace !ExplicitNamespaceKeyword -- | Expecting a type constructor but found a variable | PsErrVarForTyCon !RdrName ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -79,6 +79,7 @@ module GHC.Parser.PostProcess ( ImpExpSubSpec(..), ImpExpQcSpec(..), mkModuleImpExp, + mkPlainImpExp, mkTypeImpExp, mkDataImpExp, mkImpExpSubSpec, @@ -3241,9 +3242,7 @@ data ImpExpSubSpec = ImpExpAbs | ImpExpList [LocatedA ImpExpQcSpec] | ImpExpAllWith [LocatedA ImpExpQcSpec] -data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName) - | ImpExpQcType (EpToken "type") (LocatedN RdrName) - | ImpExpQcData (EpToken "data") (LocatedN RdrName) +data ImpExpQcSpec = ImpExpQcName (Maybe ExplicitNamespaceKeyword) (LocatedN RdrName) | ImpExpQcWildcard (EpToken "..") (EpToken ",") mkModuleImpExp :: Maybe (LWarningTxt GhcPs) -> (EpToken "(", EpToken ")") -> LocatedA ImpExpQcSpec @@ -3287,30 +3286,37 @@ mkModuleImpExp warning (top, tcp) (L l specname) subs = do (PsErrVarForTyCon name) else return $ ieNameFromSpec specname - ieNameVal (ImpExpQcName ln) = unLoc ln - ieNameVal (ImpExpQcType _ ln) = unLoc ln - ieNameVal (ImpExpQcData _ ln) = unLoc ln + ieNameVal (ImpExpQcName _ ln) = unLoc ln ieNameVal ImpExpQcWildcard{} = panic "ieNameVal got wildcard" ieNameFromSpec :: ImpExpQcSpec -> IEWrappedName GhcPs - ieNameFromSpec (ImpExpQcName (L l n)) = IEName noExtField (L l n) - ieNameFromSpec (ImpExpQcType r (L l n)) = IEType r (L l n) - ieNameFromSpec (ImpExpQcData r (L l n)) = IEData r (L l n) - ieNameFromSpec ImpExpQcWildcard{} = panic "ieName got wildcard" + ieNameFromSpec (ImpExpQcName m_kw name) = case m_kw of + Nothing -> IEName noExtField name + Just (ExplicitTypeNamespace tok) -> IEType tok name + Just (ExplicitDataNamespace tok) -> IEData tok name + ieNameFromSpec ImpExpQcWildcard{} = panic "ieNameFromSpec got wildcard" wrapped = map (fmap ieNameFromSpec) -mkTypeImpExp :: LocatedN RdrName -- TcCls or Var name space - -> P (LocatedN RdrName) -mkTypeImpExp name = - do requireExplicitNamespaces (getLocA name) - return (fmap (`setRdrNameSpace` tcClsName) name) +mkPlainImpExp :: LocatedN RdrName -> ImpExpQcSpec +mkPlainImpExp name = ImpExpQcName Nothing name -mkDataImpExp :: LocatedN RdrName - -> P (LocatedN RdrName) -mkDataImpExp name = - do requireExplicitNamespaces (getLocA name) - return name +mkTypeImpExp :: EpToken "type" + -> LocatedN RdrName -- TcCls or Var name space + -> P ImpExpQcSpec +mkTypeImpExp tok name = do + let name' = fmap (`setRdrNameSpace` tcClsName) name + ns_kw = ExplicitTypeNamespace tok + requireExplicitNamespaces ns_kw + return (ImpExpQcName (Just ns_kw) name') + +mkDataImpExp :: EpToken "data" + -> LocatedN RdrName + -> P ImpExpQcSpec +mkDataImpExp tok name = do + let ns_kw = ExplicitDataNamespace tok + requireExplicitNamespaces ns_kw + return (ImpExpQcName (Just ns_kw) name) checkImportSpec :: LocatedLI [LIE GhcPs] -> P (LocatedLI [LIE GhcPs]) checkImportSpec ie@(L _ specs) = @@ -3368,11 +3374,15 @@ failOpFewArgs (L loc op) = ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrOpFewArgs is_star_type op) } -requireExplicitNamespaces :: MonadP m => SrcSpan -> m () -requireExplicitNamespaces l = do +requireExplicitNamespaces :: MonadP m => ExplicitNamespaceKeyword -> m () +requireExplicitNamespaces kw = do allowed <- getBit ExplicitNamespacesBit unless allowed $ - addError $ mkPlainErrorMsgEnvelope l PsErrIllegalExplicitNamespace + addError $ mkPlainErrorMsgEnvelope loc $ PsErrIllegalExplicitNamespace kw + where + loc = case kw of + ExplicitTypeNamespace tok -> getEpTokenSrcSpan tok + ExplicitDataNamespace tok -> getEpTokenSrcSpan tok warnPatternNamespaceSpecifier :: MonadP m => SrcSpan -> m () warnPatternNamespaceSpecifier l = do ===================================== compiler/GHC/Parser/Types.hs ===================================== @@ -8,6 +8,7 @@ module GHC.Parser.Types , pprSumOrTuple , PatBuilder(..) , DataConBuilder(..) + , ExplicitNamespaceKeyword(..) ) where @@ -111,3 +112,7 @@ instance Outputable DataConBuilder where ppr lhs <+> ppr data_con <+> ppr rhs type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnLW + +data ExplicitNamespaceKeyword + = ExplicitTypeNamespace !(EpToken "type") + | ExplicitDataNamespace !(EpToken "data") \ No newline at end of file ===================================== testsuite/tests/parser/should_fail/T16270h.stderr ===================================== @@ -1,6 +1,5 @@ - -T16270h.hs:8:22: error: [GHC-47007] - Illegal keyword 'type' +T16270h.hs:8:17: error: [GHC-47007] + Illegal keyword ‘type’ Suggested fix: Perhaps you intended to use the ‘ExplicitNamespaces’ extension (implied by ‘TypeFamilies’ and ‘TypeOperators’) @@ -11,3 +10,4 @@ T16270h.hs:10:8: error: [GHC-21926] T16270h.hs:11:8: error: [GHC-21926] Parse error: ‘pkg!’ Version number or non-alphanumeric character in package name + ===================================== testsuite/tests/parser/should_fail/T26418.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE NoExplicitNamespaces #-} + +module T26418 (data HeadC) where + +pattern HeadC :: forall a. a -> [a] +pattern HeadC x <- x:_xs where + HeadC x = [x] + ===================================== testsuite/tests/parser/should_fail/T26418.stderr ===================================== @@ -0,0 +1,5 @@ +T26418.hs:4:16: error: [GHC-47007] + Illegal keyword ‘data’ + Suggested fix: + Perhaps you intended to use the ‘ExplicitNamespaces’ extension (implied by ‘TypeFamilies’ and ‘TypeOperators’) + ===================================== testsuite/tests/parser/should_fail/all.T ===================================== @@ -241,3 +241,4 @@ test('T25258a', normal, compile_fail, ['']) test('T25258b', normal, compile_fail, ['']) test('T25258c', normal, compile_fail, ['']) test('T25530', normal, compile_fail, ['']) +test('T26418', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/116a6a9e4bf6ab113fa17acea156c521... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/116a6a9e4bf6ab113fa17acea156c521... You're receiving this email because of your account on gitlab.haskell.org.