Parse qualified terms in type signatures

This commit allows qualified terms in type
signatures to pass the parser and to be cathced by renamer
with more informative error message. Adds a few tests.

Fixes #21605

7 files changed, 80 insertions, 9 deletions

diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 7cc43b7273..2648552bee 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2263,6 +2263,10 @@ atype :: { LHsType GhcPs }
         | STRING               { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGs $1)
                                                                      (getSTRING  $1) }
         | '_'                  { reLocA $ sL1 $1 $ mkAnonWildCardTy }
+        -- Type variables are never exported, so `M.tyvar` will be rejected by the renamer.
+        -- We let it pass the parser because the renamer can generate a better error message.
+        | QVARID                      {% let qname = mkQual tvName (getQVARID $1)
+                                         in  acsa (\cs -> sL1a $1 (HsTyVar (EpAnn (glR $1) [] cs) NotPromoted (sL1n $1 $ qname)))}
 
 -- An inst_type is what occurs in the head of an instance decl
 --      e.g.  (Foo a, Gaz b) => Wibble a b
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index e9733a8bfc..0c0e944d64 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -1097,6 +1097,9 @@ lookup_demoted rdr_name
                                      | otherwise
                                      = star_is_type_hints
                     ; unboundNameX looking_for rdr_name suggestion } }
+  | Just demoted_rdr_name <- demoteRdrNameTv rdr_name,
+    isQual rdr_name
+  = report_qualified_term_in_types rdr_name demoted_rdr_name
 
   | otherwise
   = reportUnboundName' (lf_which looking_for) rdr_name
@@ -1104,6 +1107,18 @@ lookup_demoted rdr_name
   where
     looking_for = LF WL_Constructor WL_Anywhere
 
+-- Report a qualified variable name in a type signature:
+--   badSig :: Prelude.head
+--             ^^^^^^^^^^^
+report_qualified_term_in_types :: RdrName -> RdrName -> RnM Name
+report_qualified_term_in_types rdr_name demoted_rdr_name =
+  do { mName <- lookupGlobalOccRn_maybe demoted_rdr_name
+     ; case mName of
+         (Just _) -> termNameInType looking_for rdr_name demoted_rdr_name []
+         Nothing -> unboundTermNameInTypes looking_for rdr_name demoted_rdr_name }
+  where
+    looking_for = LF WL_Constructor WL_Global
+
 -- If the given RdrName can be promoted to the type level and its promoted variant is in scope,
 -- lookup_promoted returns the corresponding type-level Name.
 -- Otherwise, the function returns Nothing.
@@ -1152,14 +1167,26 @@ its namespace to DataName and do a second lookup.
 The final result (after the renamer) will be:
   HsTyVar ("Zero", DataName)
 
-Another case of demotion happens when the compiler needs to check
+Another case of demotion happens when the user tries to
+use a qualified term at the type level:
+
+  f :: Prelude.id -> Int
+
+This signature passes the parser to be caught by the renamer.
+It allows the compiler to create more informative error messages.
+
+'Prelude.id' in the type signature is parsed as
+  HsTyVar ("id", TvName)
+
+To separate the case of a typo from the case of an
+intentional attempt to use an imported term's name the compiler demotes
+the namespace to VarName (using 'demoteTvNameSpace') and does a lookup.
+
+The same type of demotion happens when the compiler needs to check
 if a name of a type variable has already been used for a term that is in scope.
 We need to do it to check if a user should change the name
 to make his code compatible with the RequiredTypeArguments extension.
 
-This type of demotion is made via demoteTvNameSpace.
-
-
 Note [Promotion]
 ~~~~~~~~~~~~~~~
 When the user mentions a type constructor or a type variable in a
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index cb246d1c77..f9720a53e1 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -2039,7 +2039,7 @@ extract_hs_tv_bndrs_kvs tv_bndrs =
 
 extract_tv :: LocatedN RdrName -> FreeKiTyVars -> FreeKiTyVars
 extract_tv tv acc =
-  if isRdrTyVar (unLoc tv) then tv:acc else acc
+  if isRdrTyVar (unLoc tv) && (not . isQual) (unLoc tv) then tv:acc else acc
 
 -- Deletes duplicates in a list of Located things. This is used to:
 --
diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs
index d91227670d..c8e77b9e87 100644
--- a/compiler/GHC/Rename/Unbound.hs
+++ b/compiler/GHC/Rename/Unbound.hs
@@ -18,8 +18,11 @@ module GHC.Rename.Unbound
    , LookingFor(..)
    , unboundName
    , unboundNameX
+   , unboundTermNameInTypes
+   , IsTermInTypes(..)
    , notInScopeErr
    , nameSpacesRelated
+   , termNameInType
    )
 where
 
@@ -32,6 +35,7 @@ import GHC.Tc.Errors.Types
 import GHC.Tc.Utils.Monad
 import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique)
 import GHC.Utils.Misc
+import GHC.Utils.Panic (panic)
 
 import GHC.Data.Maybe
 import GHC.Data.FastString
@@ -93,6 +97,8 @@ data LookingFor = LF { lf_which :: WhatLooking
                      , lf_where :: WhereLooking
                      }
 
+data IsTermInTypes = UnknownTermInTypes RdrName | TermInTypes RdrName | NoTermInTypes
+
 mkUnboundNameRdr :: RdrName -> Name
 mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr)
 
@@ -107,11 +113,24 @@ unboundName lf rdr = unboundNameX lf rdr []
 
 unboundNameX :: LookingFor -> RdrName -> [GhcHint] -> RnM Name
 unboundNameX looking_for rdr_name hints
+  = unboundNameOrTermInType NoTermInTypes looking_for rdr_name hints
+
+unboundTermNameInTypes :: LookingFor -> RdrName -> RdrName  -> RnM Name
+unboundTermNameInTypes looking_for rdr_name demoted_rdr_name
+  = unboundNameOrTermInType (UnknownTermInTypes demoted_rdr_name) looking_for rdr_name []
+
+-- Catches imported qualified terms in type signatures
+-- with proper error message and suggestions
+termNameInType :: LookingFor -> RdrName -> RdrName -> [GhcHint] -> RnM Name
+termNameInType looking_for rdr_name demoted_rdr_name external_hints
+  = unboundNameOrTermInType (TermInTypes demoted_rdr_name) looking_for rdr_name external_hints
+
+unboundNameOrTermInType :: IsTermInTypes -> LookingFor -> RdrName -> [GhcHint] -> RnM Name
+unboundNameOrTermInType if_term_in_type looking_for rdr_name hints
   = do  { dflags <- getDynFlags
         ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags
-              err = notInScopeErr (lf_where looking_for) rdr_name
         ; if not show_helpful_errors
-          then addErr $ TcRnNotInScope err rdr_name [] hints
+          then addErr $ make_error [] hints
           else do { local_env  <- getLocalRdrEnv
                   ; global_env <- getGlobalRdrEnv
                   ; impInfo <- getImports
@@ -122,9 +141,19 @@ unboundNameX looking_for rdr_name hints
                             dflags hpt currmod global_env local_env impInfo
                             rdr_name
                   ; addErr $
-                      TcRnNotInScope err rdr_name imp_errs (hints ++ suggs) }
+                      make_error imp_errs (hints ++ suggs) }
         ; return (mkUnboundNameRdr rdr_name) }
+    where
+      name_to_search = case if_term_in_type of
+        NoTermInTypes                   -> rdr_name
+        UnknownTermInTypes demoted_name -> demoted_name
+        TermInTypes demoted_name        -> demoted_name
+
+      err = notInScopeErr (lf_where looking_for) name_to_search
 
+      make_error imp_errs hints = case if_term_in_type of
+        TermInTypes demoted_name -> TcRnTermNameInType demoted_name hints
+        _ -> TcRnNotInScope err name_to_search imp_errs hints
 
 notInScopeErr :: WhereLooking -> RdrName -> NotInScopeError
 notInScopeErr where_look rdr_name
@@ -288,7 +317,7 @@ importSuggestions looking_for global_env hpt currMod imports rdr_name
   (mod_name, occ_name) = case rdr_name of
     Unqual occ_name        -> (Nothing, occ_name)
     Qual mod_name occ_name -> (Just mod_name, occ_name)
-    _                      -> error "importSuggestions: dead code"
+    _                      -> panic "importSuggestions: dead code"
 
 
   -- What import statements provide "Mod" at all
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 2e17295073..984cf95903 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -718,6 +718,11 @@ instance Diagnostic TcRnMessage where
     TcRnNotInScope err name imp_errs _
       -> mkSimpleDecorated $
            pprScopeError name err $$ vcat (map ppr imp_errs)
+    TcRnTermNameInType name _
+      -> mkSimpleDecorated $
+           quotes (ppr name) <+>
+             (text "is a term-level binding") $+$
+             (text " and can not be used at the type level.")
     TcRnUntickedPromotedThing thing
       -> mkSimpleDecorated $
          text "Unticked promoted" <+> what
@@ -1475,6 +1480,8 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnNotInScope {}
       -> ErrorWithoutFlag
+    TcRnTermNameInType {}
+      -> ErrorWithoutFlag
     TcRnUntickedPromotedThing {}
       -> WarningWithFlag Opt_WarnUntickedPromotedConstructors
     TcRnIllegalBuiltinSyntax {}
@@ -1878,6 +1885,8 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnNotInScope err _ _ hints
       -> scopeErrorHints err ++ hints
+    TcRnTermNameInType _ hints
+      -> hints
     TcRnUntickedPromotedThing thing
       -> [SuggestAddTick thing]
     TcRnIllegalBuiltinSyntax {}
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 13bef7b699..65701f9fee 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -1717,6 +1717,7 @@ data TcRnMessage where
                  -> [ImportError]    -- ^ import errors that are relevant
                  -> [GhcHint]        -- ^ hints, e.g. enable DataKinds to refer to a promoted data constructor
                  -> TcRnMessage
+  TcRnTermNameInType :: RdrName -> [GhcHint] -> TcRnMessage
 
   {-| TcRnUntickedPromotedThing is a warning (controlled with -Wunticked-promoted-constructors)
       that is triggered by an unticked occurrence of a promoted data constructor.
diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs
index 3b7220f703..544ebc905f 100644
--- a/compiler/GHC/Types/Error/Codes.hs
+++ b/compiler/GHC/Types/Error/Codes.hs
@@ -432,6 +432,7 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnSectionWithoutParentheses"                 = 95880
   GhcDiagnosticCode "TcRnIllegalImplicitParameterBindings"          = 50730
   GhcDiagnosticCode "TcRnIllegalTupleSection"                       = 59155
+  GhcDiagnosticCode "TcRnTermNameInType"                            = 37479
 
   GhcDiagnosticCode "TcRnUntickedPromotedThing"                     = 49957
   GhcDiagnosticCode "TcRnIllegalBuiltinSyntax"                      = 39716