diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Hs/Decls.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Expr.hs | 14 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Pat.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Types.hs | 11 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Utils.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Binds.hs | 1334 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Doc.hs | 25 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Env.hs | 1702 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Expr.hs | 2210 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Expr.hs-boot | 17 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Fixity.hs | 219 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Names.hs | 1783 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Pat.hs | 897 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Source.hs | 2415 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Splice.hs | 902 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Splice.hs-boot | 14 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Types.hs | 1783 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Unbound.hs | 384 | ||||
| -rw-r--r-- | compiler/GHC/Rename/Utils.hs | 514 | ||||
| -rw-r--r-- | compiler/GHC/ThToHs.hs | 4 |
20 files changed, 14219 insertions, 19 deletions
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index 2146cc0c07..69cfd0a111 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -383,7 +383,7 @@ Plan of attack: (See RnHiFiles.getSysBinders) - When typechecking the decl, we build the implicit TyCons and Ids. - When doing so we look them up in the name cache (RnEnv.lookupSysName), + When doing so we look them up in the name cache (GHC.Rename.Env.lookupSysName), to ensure correct module and provenance is set These are the two places that we have to conjure up the magic derived @@ -908,7 +908,7 @@ Invariants ones. See Note [Dependency analsis of type, class, and instance decls] -in RnSource for more info. +in GHC.Rename.Source for more info. -} -- | Type or Class Group @@ -1412,7 +1412,7 @@ There's a wrinkle in ConDeclGADT con_args = PrefixCon [] con_res_ty = a :*: (b -> (a :*: (b -> (a :+: b)))) - - In the renamer (RnSource.rnConDecl), we unravel it afer + - In the renamer (GHC.Rename.Source.rnConDecl), we unravel it afer operator fixities are sorted. So we generate. So we end up with con_args = PrefixCon [ a :*: b, a :*: b ] diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 13ca6b0eff..12daa75187 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -179,7 +179,7 @@ This is Less Cool than what we normally do for rebindable syntax, which is to make fully-instantiated piece of evidence at every use site. The Cmd way is Less Cool because * The renamer has to predict which methods are needed. - See the tedious RnExpr.methodNamesCmd. + See the tedious GHC.Rename.Expr.methodNamesCmd. * The desugarer has to know the polymorphic type of the instantiated method. This is checked by Inst.tcSyntaxName, but is less flexible @@ -1748,7 +1748,7 @@ type GhciStmt id = Stmt id (LHsExpr id) -- For details on above see note [Api annotations] in ApiAnnotation data StmtLR idL idR body -- body should always be (LHs**** idR) = LastStmt -- Always the last Stmt in ListComp, MonadComp, - -- and (after the renamer, see RnExpr.checkLastStmt) DoExpr, MDoExpr + -- and (after the renamer, see GHC.Rename.Expr.checkLastStmt) DoExpr, MDoExpr -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff (XLastStmt idL idR body) body @@ -1776,7 +1776,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR) -- appropriate applicative expression by the desugarer, but it is intended -- to be invisible in error messages. -- - -- For full details, see Note [ApplicativeDo] in RnExpr + -- For full details, see Note [ApplicativeDo] in GHC.Rename.Expr -- | ApplicativeStmt (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body @@ -2297,7 +2297,7 @@ data HsSplice id -- AZ:TODO: use XSplice instead of HsSpliced | HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in - -- RnSplice. + -- GHC.Rename.Splice. -- This is the result of splicing a splice. It is produced by -- the renamer and consumed by the typechecker. It lives only -- between the two. @@ -2333,7 +2333,7 @@ isTypedSplice _ = False -- Quasi-quotes are untyped splices -- | Finalizers produced by a splice with -- 'Language.Haskell.TH.Syntax.addModFinalizer' -- --- See Note [Delaying modFinalizers in untyped splices] in RnSplice. For how +-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. For how -- this is used. -- newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())] @@ -2421,11 +2421,11 @@ distinguished by their UntypedSpliceFlavour UntypedExpSplice is also used for * quasi-quotes, where the pending expression expands to $(quoter "...blah...") - (see RnSplice.makePending, HsQuasiQuote case) + (see GHC.Rename.Splice.makePending, HsQuasiQuote case) * cross-stage lifting, where the pending expression expands to $(lift x) - (see RnSplice.checkCrossStageLifting) + (see GHC.Rename.Splice.checkCrossStageLifting) * Pending pattern splices (UntypedPatSplice), e.g., [| \$(f x) -> x |] diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index bb319181d3..945c2c195f 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -245,7 +245,7 @@ data Pat p -- a new hs-boot file. Not worth it. (SyntaxExpr p) -- (>=) function, of type t1->t2->Bool - (SyntaxExpr p) -- Name of '-' (see RnEnv.lookupSyntaxName) + (SyntaxExpr p) -- Name of '-' (see GHC.Rename.Env.lookupSyntaxName) -- ^ n+k pattern ------------ Pattern type signatures --------------- diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs index 46cc1ecb24..92f064144a 100644 --- a/compiler/GHC/Hs/Types.hs +++ b/compiler/GHC/Hs/Types.hs @@ -144,7 +144,7 @@ Then we use a LHsBndrSig on the binder, so that the renamer can decorate it with the variables bound by the pattern ('a' in the first example, 'k' in the second), assuming that neither of them is in scope already -See also Note [Kind and type-variable binders] in RnTypes +See also Note [Kind and type-variable binders] in GHC.Rename.Types Note [HsType binders] ~~~~~~~~~~~~~~~~~~~~~ @@ -265,7 +265,7 @@ By "stable", we mean that any two variables who do not depend on each other preserve their existing left-to-right ordering. Implicitly bound variables are collected by the extract- family of functions -(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.) in RnTypes. +(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.) in GHC.Rename.Types. These functions thus promise to keep left-to-right ordering. Look for pointers to this note to see the places where the action happens. @@ -368,7 +368,7 @@ data HsImplicitBndrs pass thing -- See Note [HsType binders] -- Implicitly-bound kind & type vars -- Order is important; see -- Note [Ordering of implicit variables] - -- in RnTypes + -- in GHC.Rename.Types , hsib_body :: thing -- Main payload (type or list of types) } @@ -602,7 +602,8 @@ data HsType pass | HsParTy (XParTy pass) (LHsType pass) -- See Note [Parens in HsSyn] in GHC.Hs.Expr - -- Parenthesis preserved for the precedence re-arrangement in RnTypes + -- Parenthesis preserved for the precedence re-arrangement in + -- GHC.Rename.Types -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, -- 'ApiAnnotation.AnnClose' @')'@ @@ -774,7 +775,7 @@ After renaming Qualified currently behaves exactly as Implicit, but it is deprecated to use it for implicit quantification. In this case, GHC 7.10 gives a warning; see -Note [Context quantification] in RnTypes, and #4426. +Note [Context quantification] in GHC.Rename.Types, and #4426. In GHC 8.0, Qualified will no longer bind variables and this will become an error. diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 1b386fd703..f9133eba87 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -239,7 +239,7 @@ nlParPat p = noLoc (ParPat noExtField p) ------------------------------- -- These are the bits of syntax that contain rebindable names --- See RnEnv.lookupSyntaxName +-- See GHC.Rename.Env.lookupSyntaxName mkHsIntegral :: IntegralLit -> HsOverLit GhcPs mkHsFractional :: FractionalLit -> HsOverLit GhcPs diff --git a/compiler/GHC/Rename/Binds.hs b/compiler/GHC/Rename/Binds.hs new file mode 100644 index 0000000000..f4c8e0effd --- /dev/null +++ b/compiler/GHC/Rename/Binds.hs @@ -0,0 +1,1334 @@ +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Renaming and dependency analysis of bindings + +This module does renaming and dependency analysis on value bindings in +the abstract syntax. It does {\em not} do cycle-checks on class or +type-synonym declarations; those cannot be done at this stage because +they may be affected by renaming (which isn't fully worked out yet). +-} + +module GHC.Rename.Binds ( + -- Renaming top-level bindings + rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS, + + -- Renaming local bindings + rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, + + -- Other bindings + rnMethodBinds, renameSigs, + rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl, + makeMiniFixityEnv, MiniFixityEnv, + HsSigCtxt(..) + ) where + +import GhcPrelude + +import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr, rnStmts ) + +import GHC.Hs +import TcRnMonad +import GHC.Rename.Types +import GHC.Rename.Pat +import GHC.Rename.Names +import GHC.Rename.Env +import GHC.Rename.Fixity +import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn + , checkDupRdrNames, warnUnusedLocalBinds + , checkUnusedRecordWildcard + , checkDupAndShadowedNames, bindLocalNamesFV ) +import DynFlags +import Module +import Name +import NameEnv +import NameSet +import RdrName ( RdrName, rdrNameOcc ) +import SrcLoc +import ListSetOps ( findDupsEq ) +import BasicTypes ( RecFlag(..), TypeOrKind(..) ) +import Digraph ( SCC(..) ) +import Bag +import Util +import Outputable +import UniqSet +import Maybes ( orElse ) +import OrdList +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Data.Foldable ( toList ) +import Data.List ( partition, sort ) +import Data.List.NonEmpty ( NonEmpty(..) ) + +{- +-- ToDo: Put the annotations into the monad, so that they arrive in the proper +-- place and can be used when complaining. + +The code tree received by the function @rnBinds@ contains definitions +in where-clauses which are all apparently mutually recursive, but which may +not really depend upon each other. For example, in the top level program +\begin{verbatim} +f x = y where a = x + y = x +\end{verbatim} +the definitions of @a@ and @y@ do not depend on each other at all. +Unfortunately, the typechecker cannot always check such definitions. +\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive +definitions. In Proceedings of the International Symposium on Programming, +Toulouse, pp. 217-39. LNCS 167. Springer Verlag.} +However, the typechecker usually can check definitions in which only the +strongly connected components have been collected into recursive bindings. +This is precisely what the function @rnBinds@ does. + +ToDo: deal with case where a single monobinds binds the same variable +twice. + +The vertag tag is a unique @Int@; the tags only need to be unique +within one @MonoBinds@, so that unique-Int plumbing is done explicitly +(heavy monad machinery not needed). + + +************************************************************************ +* * +* naming conventions * +* * +************************************************************************ + +\subsection[name-conventions]{Name conventions} + +The basic algorithm involves walking over the tree and returning a tuple +containing the new tree plus its free variables. Some functions, such +as those walking polymorphic bindings (HsBinds) and qualifier lists in +list comprehensions (@Quals@), return the variables bound in local +environments. These are then used to calculate the free variables of the +expression evaluated in these environments. + +Conventions for variable names are as follows: +\begin{itemize} +\item +new code is given a prime to distinguish it from the old. + +\item +a set of variables defined in @Exp@ is written @dvExp@ + +\item +a set of variables free in @Exp@ is written @fvExp@ +\end{itemize} + +************************************************************************ +* * +* analysing polymorphic bindings (HsBindGroup, HsBind) +* * +************************************************************************ + +\subsubsection[dep-HsBinds]{Polymorphic bindings} + +Non-recursive expressions are reconstructed without any changes at top +level, although their component expressions may have to be altered. +However, non-recursive expressions are currently not expected as +\Haskell{} programs, and this code should not be executed. + +Monomorphic bindings contain information that is returned in a tuple +(a @FlatMonoBinds@) containing: + +\begin{enumerate} +\item +a unique @Int@ that serves as the ``vertex tag'' for this binding. + +\item +the name of a function or the names in a pattern. These are a set +referred to as @dvLhs@, the defined variables of the left hand side. + +\item +the free variables of the body. These are referred to as @fvBody@. + +\item +the definition's actual code. This is referred to as just @code@. +\end{enumerate} + +The function @nonRecDvFv@ returns two sets of variables. The first is +the set of variables defined in the set of monomorphic bindings, while the +second is the set of free variables in those bindings. + +The set of variables defined in a non-recursive binding is just the +union of all of them, as @union@ removes duplicates. However, the +free variables in each successive set of cumulative bindings is the +union of those in the previous set plus those of the newest binding after +the defined variables of the previous set have been removed. + +@rnMethodBinds@ deals only with the declarations in class and +instance declarations. It expects only to see @FunMonoBind@s, and +it expects the global environment to contain bindings for the binders +(which are all class operations). + +************************************************************************ +* * +\subsubsection{ Top-level bindings} +* * +************************************************************************ +-} + +-- for top-level bindings, we need to make top-level names, +-- so we have a different entry point than for local bindings +rnTopBindsLHS :: MiniFixityEnv + -> HsValBinds GhcPs + -> RnM (HsValBindsLR GhcRn GhcPs) +rnTopBindsLHS fix_env binds + = rnValBindsLHS (topRecNameMaker fix_env) binds + +rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) +-- A hs-boot file has no bindings. +-- Return a single HsBindGroup with empty binds and renamed signatures +rnTopBindsBoot bound_names (ValBinds _ mbinds sigs) + = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) + ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs + ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) } +rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) + +{- +********************************************************* +* * + HsLocalBinds +* * +********************************************************* +-} + +rnLocalBindsAndThen :: HsLocalBinds GhcPs + -> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) +-- This version (a) assumes that the binding vars are *not* already in scope +-- (b) removes the binders from the free vars of the thing inside +-- The parser doesn't produce ThenBinds +rnLocalBindsAndThen (EmptyLocalBinds x) thing_inside = + thing_inside (EmptyLocalBinds x) emptyNameSet + +rnLocalBindsAndThen (HsValBinds x val_binds) thing_inside + = rnLocalValBindsAndThen val_binds $ \ val_binds' -> + thing_inside (HsValBinds x val_binds') + +rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do + (binds',fv_binds) <- rnIPBinds binds + (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds + return (thing, fvs_thing `plusFV` fv_binds) + +rnLocalBindsAndThen (XHsLocalBindsLR nec) _ = noExtCon nec + +rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars) +rnIPBinds (IPBinds _ ip_binds ) = do + (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds + return (IPBinds noExtField ip_binds', plusFVs fvs_s) +rnIPBinds (XHsIPBinds nec) = noExtCon nec + +rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars) +rnIPBind (IPBind _ ~(Left n) expr) = do + (expr',fvExpr) <- rnLExpr expr + return (IPBind noExtField (Left n) expr', fvExpr) +rnIPBind (XIPBind nec) = noExtCon nec + +{- +************************************************************************ +* * + ValBinds +* * +************************************************************************ +-} + +-- Renaming local binding groups +-- Does duplicate/shadow check +rnLocalValBindsLHS :: MiniFixityEnv + -> HsValBinds GhcPs + -> RnM ([Name], HsValBindsLR GhcRn GhcPs) +rnLocalValBindsLHS fix_env binds + = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds + + -- Check for duplicates and shadowing + -- Must do this *after* renaming the patterns + -- See Note [Collect binders only after renaming] in GHC.Hs.Utils + + -- We need to check for dups here because we + -- don't don't bind all of the variables from the ValBinds at once + -- with bindLocatedLocals any more. + -- + -- Note that we don't want to do this at the top level, since + -- sorting out duplicates and shadowing there happens elsewhere. + -- The behavior is even different. For example, + -- import A(f) + -- f = ... + -- should not produce a shadowing warning (but it will produce + -- an ambiguity warning if you use f), but + -- import A(f) + -- g = let f = ... in f + -- should. + ; let bound_names = collectHsValBinders binds' + -- There should be only Ids, but if there are any bogus + -- pattern synonyms, we'll collect them anyway, so that + -- we don't generate subsequent out-of-scope messages + ; envs <- getRdrEnvs + ; checkDupAndShadowedNames envs bound_names + + ; return (bound_names, binds') } + +-- renames the left-hand sides +-- generic version used both at the top level and for local binds +-- does some error checking, but not what gets done elsewhere at the top level +rnValBindsLHS :: NameMaker + -> HsValBinds GhcPs + -> RnM (HsValBindsLR GhcRn GhcPs) +rnValBindsLHS topP (ValBinds x mbinds sigs) + = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds + ; return $ ValBinds x mbinds' sigs } + where + bndrs = collectHsBindsBinders mbinds + doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs + +rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) + +-- General version used both from the top-level and for local things +-- Assumes the LHS vars are in scope +-- +-- Does not bind the local fixity declarations +rnValBindsRHS :: HsSigCtxt + -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) + +rnValBindsRHS ctxt (ValBinds _ mbinds sigs) + = do { (sigs', sig_fvs) <- renameSigs ctxt sigs + ; binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn sigs')) mbinds + ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus + + ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $ + getPatSynBinds anal_binds + -- The uses in binds_w_dus for PatSynBinds do not include + -- variables used in the patsyn builders; see + -- Note [Pattern synonym builders don't yield dependencies] + -- But psb_fvs /does/ include those builder fvs. So we + -- add them back in here to avoid bogus warnings about + -- unused variables (#12548) + + valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs + `plusDU` usesOnly patsyn_fvs + -- Put the sig uses *after* the bindings + -- so that the binders are removed from + -- the uses in the sigs + + ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) } + +rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b) + +-- Wrapper for local binds +-- +-- The *client* of this function is responsible for checking for unused binders; +-- it doesn't (and can't: we don't have the thing inside the binds) happen here +-- +-- The client is also responsible for bringing the fixities into scope +rnLocalValBindsRHS :: NameSet -- names bound by the LHSes + -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) +rnLocalValBindsRHS bound_names binds + = rnValBindsRHS (LocalBindCtxt bound_names) binds + +-- for local binds +-- wrapper that does both the left- and right-hand sides +-- +-- here there are no local fixity decls passed in; +-- the local fixity decls come from the ValBinds sigs +rnLocalValBindsAndThen + :: HsValBinds GhcPs + -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) +rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside + = do { -- (A) Create the local fixity environment + new_fixities <- makeMiniFixityEnv [ L loc sig + | L loc (FixSig _ sig) <- sigs] + + -- (B) Rename the LHSes + ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds + + -- ...and bring them (and their fixities) into scope + ; bindLocalNamesFV bound_names $ + addLocalFixities new_fixities bound_names $ do + + { -- (C) Do the RHS and thing inside + (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs + ; (result, result_fvs) <- thing_inside binds' (allUses dus) + + -- Report unused bindings based on the (accurate) + -- findUses. E.g. + -- let x = x in 3 + -- should report 'x' unused + ; let real_uses = findUses dus result_fvs + -- Insert fake uses for variables introduced implicitly by + -- wildcards (#4404) + rec_uses = hsValBindsImplicits binds' + implicit_uses = mkNameSet $ concatMap snd + $ rec_uses + ; mapM_ (\(loc, ns) -> + checkUnusedRecordWildcard loc real_uses (Just ns)) + rec_uses + ; warnUnusedLocalBinds bound_names + (real_uses `unionNameSet` implicit_uses) + + ; let + -- The variables "used" in the val binds are: + -- (1) the uses of the binds (allUses) + -- (2) the FVs of the thing-inside + all_uses = allUses dus `plusFV` result_fvs + -- Note [Unused binding hack] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Note that *in contrast* to the above reporting of + -- unused bindings, (1) above uses duUses to return *all* + -- the uses, even if the binding is unused. Otherwise consider: + -- x = 3 + -- y = let p = x in 'x' -- NB: p not used + -- If we don't "see" the dependency of 'y' on 'x', we may put the + -- bindings in the wrong order, and the type checker will complain + -- that x isn't in scope + -- + -- But note that this means we won't report 'x' as unused, + -- whereas we would if we had { x = 3; p = x; y = 'x' } + + ; return (result, all_uses) }} + -- The bound names are pruned out of all_uses + -- by the bindLocalNamesFV call above + +rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs) + + +--------------------- + +-- renaming a single bind + +rnBindLHS :: NameMaker + -> SDoc + -> HsBind GhcPs + -- returns the renamed left-hand side, + -- and the FreeVars *of the LHS* + -- (i.e., any free variables of the pattern) + -> RnM (HsBindLR GhcRn GhcPs) + +rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat }) + = do + -- we don't actually use the FV processing of rnPatsAndThen here + (pat',pat'_fvs) <- rnBindPat name_maker pat + return (bind { pat_lhs = pat', pat_ext = pat'_fvs }) + -- We temporarily store the pat's FVs in bind_fvs; + -- gets updated to the FVs of the whole bind + -- when doing the RHS below + +rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name }) + = do { name <- applyNameMaker name_maker rdr_name + ; return (bind { fun_id = name + , fun_ext = noExtField }) } + +rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname }) + | isTopRecNameMaker name_maker + = do { addLocM checkConName rdrname + ; name <- lookupLocatedTopBndrRn rdrname -- Should be in scope already + ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) } + + | otherwise -- Pattern synonym, not at top level + = do { addErr localPatternSynonymErr -- Complain, but make up a fake + -- name so that we can carry on + ; name <- applyNameMaker name_maker rdrname + ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) } + where + localPatternSynonymErr :: SDoc + localPatternSynonymErr + = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname)) + 2 (text "Pattern synonym declarations are only valid at top level") + +rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) + +rnLBind :: (Name -> [Name]) -- Signature tyvar function + -> LHsBindLR GhcRn GhcPs + -> RnM (LHsBind GhcRn, [Name], Uses) +rnLBind sig_fn (L loc bind) + = setSrcSpan loc $ + do { (bind', bndrs, dus) <- rnBind sig_fn bind + ; return (L loc bind', bndrs, dus) } + +-- assumes the left-hands-side vars are in scope +rnBind :: (Name -> [Name]) -- Signature tyvar function + -> HsBindLR GhcRn GhcPs + -> RnM (HsBind GhcRn, [Name], Uses) +rnBind _ bind@(PatBind { pat_lhs = pat + , pat_rhs = grhss + -- pat fvs were stored in bind_fvs + -- after processing the LHS + , pat_ext = pat_fvs }) + = do { mod <- getModule + ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss + + -- No scoped type variables for pattern bindings + ; let all_fvs = pat_fvs `plusFV` rhs_fvs + fvs' = filterNameSet (nameIsLocalOrFrom mod) all_fvs + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan + bndrs = collectPatBinders pat + bind' = bind { pat_rhs = grhss' + , pat_ext = fvs' } + + ok_nobind_pat + = -- See Note [Pattern bindings that bind no variables] + case unLoc pat of + WildPat {} -> True + BangPat {} -> True -- #9127, #13646 + SplicePat {} -> True + _ -> False + + -- Warn if the pattern binds no variables + -- See Note [Pattern bindings that bind no variables] + ; whenWOptM Opt_WarnUnusedPatternBinds $ + when (null bndrs && not ok_nobind_pat) $ + addWarn (Reason Opt_WarnUnusedPatternBinds) $ + unusedPatBindWarn bind' + + ; fvs' `seq` -- See Note [Free-variable space leak] + return (bind', bndrs, all_fvs) } + +rnBind sig_fn bind@(FunBind { fun_id = name + , fun_matches = matches }) + -- invariant: no free vars here when it's a FunBind + = do { let plain_name = unLoc name + + ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ + -- bindSigTyVars tests for LangExt.ScopedTyVars + rnMatchGroup (mkPrefixFunRhs name) + rnLExpr matches + ; let is_infix = isInfixFunBind bind + ; when is_infix $ checkPrecMatch plain_name matches' + + ; mod <- getModule + ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan + + ; fvs' `seq` -- See Note [Free-variable space leak] + return (bind { fun_matches = matches' + , fun_ext = fvs' }, + [plain_name], rhs_fvs) + } + +rnBind sig_fn (PatSynBind x bind) + = do { (bind', name, fvs) <- rnPatSynBind sig_fn bind + ; return (PatSynBind x bind', name, fvs) } + +rnBind _ b = pprPanic "rnBind" (ppr b) + +{- Note [Pattern bindings that bind no variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally, we want to warn about pattern bindings like + Just _ = e +because they don't do anything! But we have three exceptions: + +* A wildcard pattern + _ = rhs + which (a) is not that different from _v = rhs + (b) is sometimes used to give a type sig for, + or an occurrence of, a variable on the RHS + +* A strict pattern binding; that is, one with an outermost bang + !Just _ = e + This can fail, so unlike the lazy variant, it is not a no-op. + Moreover, #13646 argues that even for single constructor + types, you might want to write the constructor. See also #9127. + +* A splice pattern + $(th-lhs) = rhs + It is impossible to determine whether or not th-lhs really + binds any variable. We should disable the warning for any pattern + which contain splices, but that is a more expensive check. + +Note [Free-variable space leak] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have + fvs' = trim fvs +and we seq fvs' before turning it as part of a record. + +The reason is that trim is sometimes something like + \xs -> intersectNameSet (mkNameSet bound_names) xs +and we don't want to retain the list bound_names. This showed up in +trac ticket #1136. +-} + +{- ********************************************************************* +* * + Dependency analysis and other support functions +* * +********************************************************************* -} + +depAnalBinds :: Bag (LHsBind GhcRn, [Name], Uses) + -> ([(RecFlag, LHsBinds GhcRn)], DefUses) +-- Dependency analysis; this is important so that +-- unused-binding reporting is accurate +depAnalBinds binds_w_dus + = (map get_binds sccs, toOL $ map get_du sccs) + where + sccs = depAnal (\(_, defs, _) -> defs) + (\(_, _, uses) -> nonDetEltsUniqSet uses) + -- It's OK to use nonDetEltsUniqSet here as explained in + -- Note [depAnal determinism] in NameEnv. + (bagToList binds_w_dus) + + get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind) + get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus]) + + get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses) + get_du (CyclicSCC binds_w_dus) = (Just defs, uses) + where + defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs] + uses = unionNameSets [u | (_,_,u) <- binds_w_dus] + +--------------------- +-- Bind the top-level forall'd type variables in the sigs. +-- E.g f :: forall a. a -> a +-- f = rhs +-- The 'a' scopes over the rhs +-- +-- NB: there'll usually be just one (for a function binding) +-- but if there are many, one may shadow the rest; too bad! +-- e.g x :: forall a. [a] -> [a] +-- y :: forall a. [(a,a)] -> a +-- (x,y) = e +-- In e, 'a' will be in scope, and it'll be the one from 'y'! + +mkScopedTvFn :: [LSig GhcRn] -> (Name -> [Name]) +-- Return a lookup function that maps an Id Name to the names +-- of the type variables that should scope over its body. +mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` [] + where + env = mkHsSigEnv get_scoped_tvs sigs + + get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name]) + -- Returns (binders, scoped tvs for those binders) + get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty)) + = Just (names, hsScopedTvs sig_ty) + get_scoped_tvs (L _ (TypeSig _ names sig_ty)) + = Just (names, hsWcScopedTvs sig_ty) + get_scoped_tvs (L _ (PatSynSig _ names sig_ty)) + = Just (names, hsScopedTvs sig_ty) + get_scoped_tvs _ = Nothing + +-- Process the fixity declarations, making a FastString -> (Located Fixity) map +-- (We keep the location around for reporting duplicate fixity declarations.) +-- +-- Checks for duplicates, but not that only locally defined things are fixed. +-- Note: for local fixity declarations, duplicates would also be checked in +-- check_sigs below. But we also use this function at the top level. + +makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv + +makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls + where + add_one_sig env (L loc (FixitySig _ names fixity)) = + foldlM add_one env [ (loc,name_loc,name,fixity) + | L name_loc name <- names ] + add_one_sig _ (L _ (XFixitySig nec)) = noExtCon nec + + add_one env (loc, name_loc, name,fixity) = do + { -- this fixity decl is a duplicate iff + -- the ReaderName's OccName's FastString is already in the env + -- (we only need to check the local fix_env because + -- definitions of non-local will be caught elsewhere) + let { fs = occNameFS (rdrNameOcc name) + ; fix_item = L loc fixity }; + + case lookupFsEnv env fs of + Nothing -> return $ extendFsEnv env fs fix_item + Just (L loc' _) -> do + { setSrcSpan loc $ + addErrAt name_loc (dupFixityDecl loc' name) + ; return env} + } + +dupFixityDecl :: SrcSpan -> RdrName -> SDoc +dupFixityDecl loc rdr_name + = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name), + text "also at " <+> ppr loc] + + +{- ********************************************************************* +* * + Pattern synonym bindings +* * +********************************************************************* -} + +rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function + -> PatSynBind GhcRn GhcPs + -> RnM (PatSynBind GhcRn GhcRn, [Name], Uses) +rnPatSynBind sig_fn bind@(PSB { psb_id = L l name + , psb_args = details + , psb_def = pat + , psb_dir = dir }) + -- invariant: no free vars here when it's a FunBind + = do { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms + ; unless pattern_synonym_ok (addErr patternSynonymErr) + ; let scoped_tvs = sig_fn name + + ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $ + rnPat PatSyn pat $ \pat' -> + -- We check the 'RdrName's instead of the 'Name's + -- so that the binding locations are reported + -- from the left-hand side + case details of + PrefixCon vars -> + do { checkDupRdrNames vars + ; names <- mapM lookupPatSynBndr vars + ; return ( (pat', PrefixCon names) + , mkFVs (map unLoc names)) } + InfixCon var1 var2 -> + do { checkDupRdrNames [var1, var2] + ; name1 <- lookupPatSynBndr var1 + ; name2 <- lookupPatSynBndr var2 + -- ; checkPrecMatch -- TODO + ; return ( (pat', InfixCon name1 name2) + , mkFVs (map unLoc [name1, name2])) } + RecCon vars -> + do { checkDupRdrNames (map recordPatSynSelectorId vars) + ; let rnRecordPatSynField + (RecordPatSynField { recordPatSynSelectorId = visible + , recordPatSynPatVar = hidden }) + = do { visible' <- lookupLocatedTopBndrRn visible + ; hidden' <- lookupPatSynBndr hidden + ; return $ RecordPatSynField { recordPatSynSelectorId = visible' + , recordPatSynPatVar = hidden' } } + ; names <- mapM rnRecordPatSynField vars + ; return ( (pat', RecCon names) + , mkFVs (map (unLoc . recordPatSynPatVar) names)) } + + ; (dir', fvs2) <- case dir of + Unidirectional -> return (Unidirectional, emptyFVs) + ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs) + ExplicitBidirectional mg -> + do { (mg', fvs) <- bindSigTyVarsFV scoped_tvs $ + rnMatchGroup (mkPrefixFunRhs (L l name)) + rnLExpr mg + ; return (ExplicitBidirectional mg', fvs) } + + ; mod <- getModule + ; let fvs = fvs1 `plusFV` fvs2 + fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs + -- Keep locally-defined Names + -- As well as dependency analysis, we need these for the + -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan + + bind' = bind{ psb_args = details' + , psb_def = pat' + , psb_dir = dir' + , psb_ext = fvs' } + selector_names = case details' of + RecCon names -> + map (unLoc . recordPatSynSelectorId) names + _ -> [] + + ; fvs' `seq` -- See Note [Free-variable space leak] + return (bind', name : selector_names , fvs1) + -- Why fvs1? See Note [Pattern synonym builders don't yield dependencies] + } + where + -- See Note [Renaming pattern synonym variables] + lookupPatSynBndr = wrapLocM lookupLocalOccRn + + patternSynonymErr :: SDoc + patternSynonymErr + = hang (text "Illegal pattern synonym declaration") + 2 (text "Use -XPatternSynonyms to enable this extension") + +rnPatSynBind _ (XPatSynBind nec) = noExtCon nec + +{- +Note [Renaming pattern synonym variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We rename pattern synonym declaractions backwards to normal to reuse +the logic already implemented for renaming patterns. + +We first rename the RHS of a declaration which brings into +scope the variables bound by the pattern (as they would be +in normal function definitions). We then lookup the variables +which we want to bind in this local environment. + +It is crucial that we then only lookup in the *local* environment which +only contains the variables brought into scope by the pattern and nothing +else. Amazingly no-one encountered this bug for 3 GHC versions but +it was possible to define a pattern synonym which referenced global +identifiers and worked correctly. + +``` +x = 5 + +pattern P :: Int -> () +pattern P x <- _ + +f (P x) = x + +> f () = 5 +``` + +See #13470 for the original report. + +Note [Pattern synonym builders don't yield dependencies] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When renaming a pattern synonym that has an explicit builder, +references in the builder definition should not be used when +calculating dependencies. For example, consider the following pattern +synonym definition: + +pattern P x <- C1 x where + P x = f (C1 x) + +f (P x) = C2 x + +In this case, 'P' needs to be typechecked in two passes: + +1. Typecheck the pattern definition of 'P', which fully determines the + type of 'P'. This step doesn't require knowing anything about 'f', + since the builder definition is not looked at. + +2. Typecheck the builder definition, which needs the typechecked + definition of 'f' to be in scope; done by calls oo tcPatSynBuilderBind + in TcBinds.tcValBinds. + +This behaviour is implemented in 'tcValBinds', but it crucially +depends on 'P' not being put in a recursive group with 'f' (which +would make it look like a recursive pattern synonym a la 'pattern P = +P' which is unsound and rejected). + +So: + * We do not include builder fvs in the Uses returned by rnPatSynBind + (which is then used for dependency analysis) + * But we /do/ include them in the psb_fvs for the PatSynBind + * In rnValBinds we record these builder uses, to avoid bogus + unused-variable warnings (#12548) +-} + +{- ********************************************************************* +* * + Class/instance method bindings +* * +********************************************************************* -} + +{- @rnMethodBinds@ is used for the method bindings of a class and an instance +declaration. Like @rnBinds@ but without dependency analysis. + +NOTA BENE: we record each {\em binder} of a method-bind group as a free variable. +That's crucial when dealing with an instance decl: +\begin{verbatim} + instance Foo (T a) where + op x = ... +\end{verbatim} +This might be the {\em sole} occurrence of @op@ for an imported class @Foo@, +and unless @op@ occurs we won't treat the type signature of @op@ in the class +decl for @Foo@ as a source of instance-decl gates. But we should! Indeed, +in many ways the @op@ in an instance decl is just like an occurrence, not +a binder. +-} + +rnMethodBinds :: Bool -- True <=> is a class declaration + -> Name -- Class name + -> [Name] -- Type variables from the class/instance header + -> LHsBinds GhcPs -- Binds + -> [LSig GhcPs] -- and signatures/pragmas + -> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars) +-- Used for +-- * the default method bindings in a class decl +-- * the method bindings in an instance decl +rnMethodBinds is_cls_decl cls ktv_names binds sigs + = do { checkDupRdrNames (collectMethodBinders binds) + -- Check that the same method is not given twice in the + -- same instance decl instance C T where + -- f x = ... + -- g y = ... + -- f x = ... + -- We must use checkDupRdrNames because the Name of the + -- method is the Name of the class selector, whose SrcSpan + -- points to the class declaration; and we use rnMethodBinds + -- for instance decls too + + -- Rename the bindings LHSs + ; binds' <- foldrM (rnMethodBindLHS is_cls_decl cls) emptyBag binds + + -- Rename the pragmas and signatures + -- Annoyingly the type variables /are/ in scope for signatures, but + -- /are not/ in scope in the SPECIALISE instance pramas; e.g. + -- instance Eq a => Eq (T a) where + -- (==) :: a -> a -> a + -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} + ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs + bound_nms = mkNameSet (collectHsBindsBinders binds') + sig_ctxt | is_cls_decl = ClsDeclCtxt cls + | otherwise = InstDeclCtxt bound_nms + ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags + ; (other_sigs', sig_fvs) <- extendTyVarEnvFVRn ktv_names $ + renameSigs sig_ctxt other_sigs + + -- Rename the bindings RHSs. Again there's an issue about whether the + -- type variables from the class/instance head are in scope. + -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables + ; scoped_tvs <- xoptM LangExt.ScopedTypeVariables + ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $ + do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds' + ; let bind_fvs = foldr (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2) + emptyFVs binds_w_dus + ; return (mapBag fstOf3 binds_w_dus, bind_fvs) } + + ; return ( binds'', spec_inst_prags' ++ other_sigs' + , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) } + where + -- For the method bindings in class and instance decls, we extend + -- the type variable environment iff -XScopedTypeVariables + maybe_extend_tyvar_env scoped_tvs thing_inside + | scoped_tvs = extendTyVarEnvFVRn ktv_names thing_inside + | otherwise = thing_inside + +rnMethodBindLHS :: Bool -> Name + -> LHsBindLR GhcPs GhcPs + -> LHsBindsLR GhcRn GhcPs + -> RnM (LHsBindsLR GhcRn GhcPs) +rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest + = setSrcSpan loc $ do + do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name + -- We use the selector name as the binder + ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField } + ; return (L loc bind' `consBag` rest ) } + +-- Report error for all other forms of bindings +-- This is why we use a fold rather than map +rnMethodBindLHS is_cls_decl _ (L loc bind) rest + = do { addErrAt loc $ + vcat [ what <+> text "not allowed in" <+> decl_sort + , nest 2 (ppr bind) ] + ; return rest } + where + decl_sort | is_cls_decl = text "class declaration:" + | otherwise = text "instance declaration:" + what = case bind of + PatBind {} -> text "Pattern bindings (except simple variables)" + PatSynBind {} -> text "Pattern synonyms" + -- Associated pattern synonyms are not implemented yet + _ -> pprPanic "rnMethodBind" (ppr bind) + +{- +************************************************************************ +* * +\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)} +* * +************************************************************************ + +@renameSigs@ checks for: +\begin{enumerate} +\item more than one sig for one thing; +\item signatures given for things not bound here; +\end{enumerate} + +At the moment we don't gather free-var info from the types in +signatures. We'd only need this if we wanted to report unused tyvars. +-} + +renameSigs :: HsSigCtxt + -> [LSig GhcPs] + -> RnM ([LSig GhcRn], FreeVars) +-- Renames the signatures and performs error checks +renameSigs ctxt sigs + = do { mapM_ dupSigDeclErr (findDupSigs sigs) + + ; checkDupMinimalSigs sigs + + ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs + + ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs' + ; mapM_ misplacedSigErr bad_sigs -- Misplaced + + ; return (good_sigs, sig_fvs) } + +---------------------- +-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory +-- because this won't work for: +-- instance Foo T where +-- {-# INLINE op #-} +-- Baz.op = ... +-- We'll just rename the INLINE prag to refer to whatever other 'op' +-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) +-- Doesn't seem worth much trouble to sort this. + +renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars) +renameSig _ (IdSig _ x) + = return (IdSig noExtField x, emptyFVs) -- Actually this never occurs + +renameSig ctxt sig@(TypeSig _ vs ty) + = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + ; let doc = TypeSigCtx (ppr_sig_bndrs vs) + ; (new_ty, fvs) <- rnHsSigWcType BindUnlessForall doc ty + ; return (TypeSig noExtField new_vs new_ty, fvs) } + +renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty) + = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures + ; when (is_deflt && not defaultSigs_on) $ + addErr (defaultSigErr sig) + ; new_v <- mapM (lookupSigOccRn ctxt sig) vs + ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty + ; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) } + where + (v1:_) = vs + ty_ctxt = GenericCtx (text "a class method signature for" + <+> quotes (ppr v1)) + +renameSig _ (SpecInstSig _ src ty) + = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx TypeLevel ty + ; return (SpecInstSig noExtField src new_ty,fvs) } + +-- {-# SPECIALISE #-} pragmas can refer to imported Ids +-- so, in the top-level case (when mb_names is Nothing) +-- we use lookupOccRn. If there's both an imported and a local 'f' +-- then the SPECIALISE pragma is ambiguous, unlike all other signatures +renameSig ctxt sig@(SpecSig _ v tys inl) + = do { new_v <- case ctxt of + TopSigCtxt {} -> lookupLocatedOccRn v + _ -> lookupSigOccRn ctxt sig v + ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys + ; return (SpecSig noExtField new_v new_ty inl, fvs) } + where + ty_ctxt = GenericCtx (text "a SPECIALISE signature for" + <+> quotes (ppr v)) + do_one (tys,fvs) ty + = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty + ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } + +renameSig ctxt sig@(InlineSig _ v s) + = do { new_v <- lookupSigOccRn ctxt sig v + ; return (InlineSig noExtField new_v s, emptyFVs) } + +renameSig ctxt (FixSig _ fsig) + = do { new_fsig <- rnSrcFixityDecl ctxt fsig + ; return (FixSig noExtField new_fsig, emptyFVs) } + +renameSig ctxt sig@(MinimalSig _ s (L l bf)) + = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf + return (MinimalSig noExtField s (L l new_bf), emptyFVs) + +renameSig ctxt sig@(PatSynSig _ vs ty) + = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty + ; return (PatSynSig noExtField new_vs ty', fvs) } + where + ty_ctxt = GenericCtx (text "a pattern synonym signature for" + <+> ppr_sig_bndrs vs) + +renameSig ctxt sig@(SCCFunSig _ st v s) + = do { new_v <- lookupSigOccRn ctxt sig v + ; return (SCCFunSig noExtField st new_v s, emptyFVs) } + +-- COMPLETE Sigs can refer to imported IDs which is why we use +-- lookupLocatedOccRn rather than lookupSigOccRn +renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty) + = do new_bf <- traverse lookupLocatedOccRn bf + new_mty <- traverse lookupLocatedOccRn mty + + this_mod <- fmap tcg_mod getGblEnv + unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ do + -- Why 'any'? See Note [Orphan COMPLETE pragmas] + addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError + + return (CompleteMatchSig noExtField s (L l new_bf) new_mty, emptyFVs) + where + orphanError :: SDoc + orphanError = + text "Orphan COMPLETE pragmas not supported" $$ + text "A COMPLETE pragma must mention at least one data constructor" $$ + text "or pattern synonym defined in the same module." + +renameSig _ (XSig nec) = noExtCon nec + +{- +Note [Orphan COMPLETE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We define a COMPLETE pragma to be a non-orphan if it includes at least +one conlike defined in the current module. Why is this sufficient? +Well if you have a pattern match + + case expr of + P1 -> ... + P2 -> ... + P3 -> ... + +any COMPLETE pragma which mentions a conlike other than P1, P2 or P3 +will not be of any use in verifying that the pattern match is +exhaustive. So as we have certainly read the interface files that +define P1, P2 and P3, we will have loaded all non-orphan COMPLETE +pragmas that could be relevant to this pattern match. + +For now we simply disallow orphan COMPLETE pragmas, as the added +complexity of supporting them properly doesn't seem worthwhile. +-} + +ppr_sig_bndrs :: [Located RdrName] -> SDoc +ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) + +okHsSig :: HsSigCtxt -> LSig (GhcPass a) -> Bool +okHsSig ctxt (L _ sig) + = case (sig, ctxt) of + (ClassOpSig {}, ClsDeclCtxt {}) -> True + (ClassOpSig {}, InstDeclCtxt {}) -> True + (ClassOpSig {}, _) -> False + + (TypeSig {}, ClsDeclCtxt {}) -> False + (TypeSig {}, InstDeclCtxt {}) -> False + (TypeSig {}, _) -> True + + (PatSynSig {}, TopSigCtxt{}) -> True + (PatSynSig {}, _) -> False + + (FixSig {}, InstDeclCtxt {}) -> False + (FixSig {}, _) -> True + + (IdSig {}, TopSigCtxt {}) -> True + (IdSig {}, InstDeclCtxt {}) -> True + (IdSig {}, _) -> False + + (InlineSig {}, HsBootCtxt {}) -> False + (InlineSig {}, _) -> True + + (SpecSig {}, TopSigCtxt {}) -> True + (SpecSig {}, LocalBindCtxt {}) -> True + (SpecSig {}, InstDeclCtxt {}) -> True + (SpecSig {}, _) -> False + + (SpecInstSig {}, InstDeclCtxt {}) -> True + (SpecInstSig {}, _) -> False + + (MinimalSig {}, ClsDeclCtxt {}) -> True + (MinimalSig {}, _) -> False + + (SCCFunSig {}, HsBootCtxt {}) -> False + (SCCFunSig {}, _) -> True + + (CompleteMatchSig {}, TopSigCtxt {} ) -> True + (CompleteMatchSig {}, _) -> False + + (XSig nec, _) -> noExtCon nec + +------------------- +findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)] +-- Check for duplicates on RdrName version, +-- because renamed version has unboundName for +-- not-in-scope binders, which gives bogus dup-sig errors +-- NB: in a class decl, a 'generic' sig is not considered +-- equal to an ordinary sig, so we allow, say +-- class C a where +-- op :: a -> a +-- default op :: Eq a => a -> a +findDupSigs sigs + = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs) + where + expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig) + expand_sig sig@(InlineSig _ n _) = [(n,sig)] + expand_sig sig@(TypeSig _ ns _) = [(n,sig) | n <- ns] + expand_sig sig@(ClassOpSig _ _ ns _) = [(n,sig) | n <- ns] + expand_sig sig@(PatSynSig _ ns _ ) = [(n,sig) | n <- ns] + expand_sig sig@(SCCFunSig _ _ n _) = [(n,sig)] + expand_sig _ = [] + + matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2 + mtch (FixSig {}) (FixSig {}) = True + mtch (InlineSig {}) (InlineSig {}) = True + mtch (TypeSig {}) (TypeSig {}) = True + mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2 + mtch (PatSynSig _ _ _) (PatSynSig _ _ _) = True + mtch (SCCFunSig{}) (SCCFunSig{}) = True + mtch _ _ = False + +-- Warn about multiple MINIMAL signatures +checkDupMinimalSigs :: [LSig GhcPs] -> RnM () +checkDupMinimalSigs sigs + = case filter isMinimalLSig sigs of + minSigs@(_:_:_) -> dupMinimalSigErr minSigs + _ -> return () + +{- +************************************************************************ +* * +\subsection{Match} +* * +************************************************************************ +-} + +rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> MatchGroup GhcPs (Located (body GhcPs)) + -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars) +rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin }) + = do { empty_case_ok <- xoptM LangExt.EmptyCase + ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt)) + ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms + ; return (mkMatchGroup origin new_ms, ms_fvs) } +rnMatchGroup _ _ (XMatchGroup nec) = noExtCon nec + +rnMatch :: Outputable (body GhcPs) => HsMatchContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> LMatch GhcPs (Located (body GhcPs)) + -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars) +rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody) + +rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> Match GhcPs (Located (body GhcPs)) + -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars) +rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss }) + = do { -- Note that there are no local fixity decls for matches + ; rnPats ctxt pats $ \ pats' -> do + { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss + ; let mf' = case (ctxt, mf) of + (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ }) + -> mf { mc_fun = L lf funid } + _ -> ctxt + ; return (Match { m_ext = noExtField, m_ctxt = mf', m_pats = pats' + , m_grhss = grhss'}, grhss_fvs ) }} +rnMatch' _ _ (XMatch nec) = noExtCon nec + +emptyCaseErr :: HsMatchContext Name -> SDoc +emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) + 2 (text "Use EmptyCase to allow this") + where + pp_ctxt = case ctxt of + CaseAlt -> text "case expression" + LambdaExpr -> text "\\case expression" + _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt + +{- +************************************************************************ +* * +\subsubsection{Guarded right-hand sides (GRHSs)} +* * +************************************************************************ +-} + +rnGRHSs :: HsMatchContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> GRHSs GhcPs (Located (body GhcPs)) + -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars) +rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds)) + = rnLocalBindsAndThen binds $ \ binds' _ -> do + (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss + return (GRHSs noExtField grhss' (L l binds'), fvGRHSs) +rnGRHSs _ _ (XGRHSs nec) = noExtCon nec + +rnGRHS :: HsMatchContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> LGRHS GhcPs (Located (body GhcPs)) + -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars) +rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody) + +rnGRHS' :: HsMatchContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> GRHS GhcPs (Located (body GhcPs)) + -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars) +rnGRHS' ctxt rnBody (GRHS _ guards rhs) + = do { pattern_guards_allowed <- xoptM LangExt.PatternGuards + ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ -> + rnBody rhs + + ; unless (pattern_guards_allowed || is_standard_guard guards') + (addWarn NoReason (nonStdGuardErr guards')) + + ; return (GRHS noExtField guards' rhs', fvs) } + where + -- Standard Haskell 1.4 guards are just a single boolean + -- expression, rather than a list of qualifiers as in the + -- Glasgow extension + is_standard_guard [] = True + is_standard_guard [L _ (BodyStmt {})] = True + is_standard_guard _ = False +rnGRHS' _ _ (XGRHS nec) = noExtCon nec + +{- +********************************************************* +* * + Source-code fixity declarations +* * +********************************************************* +-} + +rnSrcFixityDecl :: HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn) +-- Rename a fixity decl, so we can put +-- the renamed decl in the renamed syntax tree +-- Errors if the thing being fixed is not defined locally. +rnSrcFixityDecl sig_ctxt = rn_decl + where + rn_decl :: FixitySig GhcPs -> RnM (FixitySig GhcRn) + -- GHC extension: look up both the tycon and data con + -- for con-like things; hence returning a list + -- If neither are in scope, report an error; otherwise + -- return a fixity sig for each (slightly odd) + rn_decl (FixitySig _ fnames fixity) + = do names <- concatMapM lookup_one fnames + return (FixitySig noExtField names fixity) + rn_decl (XFixitySig nec) = noExtCon nec + + lookup_one :: Located RdrName -> RnM [Located Name] + lookup_one (L name_loc rdr_name) + = setSrcSpan name_loc $ + -- This lookup will fail if the name is not defined in the + -- same binding group as this fixity declaration. + do names <- lookupLocalTcNames sig_ctxt what rdr_name + return [ L name_loc name | (_, name) <- names ] + what = text "fixity signature" + +{- +************************************************************************ +* * +\subsection{Error messages} +* * +************************************************************************ +-} + +dupSigDeclErr :: NonEmpty (Located RdrName, Sig GhcPs) -> RnM () +dupSigDeclErr pairs@((L loc name, sig) :| _) + = addErrAt loc $ + vcat [ text "Duplicate" <+> what_it_is + <> text "s for" <+> quotes (ppr name) + , text "at" <+> vcat (map ppr $ sort + $ map (getLoc . fst) + $ toList pairs) + ] + where + what_it_is = hsSigDoc sig + +misplacedSigErr :: LSig GhcRn -> RnM () +misplacedSigErr (L loc sig) + = addErrAt loc $ + sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] + +defaultSigErr :: Sig GhcPs -> SDoc +defaultSigErr sig = vcat [ hang (text "Unexpected default signature:") + 2 (ppr sig) + , text "Use DefaultSignatures to enable default signatures" ] + +bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc +bindsInHsBootFile mbinds + = hang (text "Bindings in hs-boot files are not allowed") + 2 (ppr mbinds) + +nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc +nonStdGuardErr guards + = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)") + 4 (interpp'SP guards) + +unusedPatBindWarn :: HsBind GhcRn -> SDoc +unusedPatBindWarn bind + = hang (text "This pattern-binding binds no variables:") + 2 (ppr bind) + +dupMinimalSigErr :: [LSig GhcPs] -> RnM () +dupMinimalSigErr sigs@(L loc _ : _) + = addErrAt loc $ + vcat [ text "Multiple minimal complete definitions" + , text "at" <+> vcat (map ppr $ sort $ map getLoc sigs) + , text "Combine alternative minimal complete definitions with `|'" ] +dupMinimalSigErr [] = panic "dupMinimalSigErr" diff --git a/compiler/GHC/Rename/Doc.hs b/compiler/GHC/Rename/Doc.hs new file mode 100644 index 0000000000..2f6a796196 --- /dev/null +++ b/compiler/GHC/Rename/Doc.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ViewPatterns #-} + +module GHC.Rename.Doc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where + +import GhcPrelude + +import TcRnTypes +import GHC.Hs +import SrcLoc + + +rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString) +rnMbLHsDoc mb_doc = case mb_doc of + Just doc -> do + doc' <- rnLHsDoc doc + return (Just doc') + Nothing -> return Nothing + +rnLHsDoc :: LHsDocString -> RnM LHsDocString +rnLHsDoc (L pos doc) = do + doc' <- rnHsDoc doc + return (L pos doc') + +rnHsDoc :: HsDocString -> RnM HsDocString +rnHsDoc = pure diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs new file mode 100644 index 0000000000..3b0f766a37 --- /dev/null +++ b/compiler/GHC/Rename/Env.hs @@ -0,0 +1,1702 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-2006 + +GHC.Rename.Env contains functions which convert RdrNames into Names. + +-} + +{-# LANGUAGE CPP, MultiWayIf, NamedFieldPuns #-} + +module GHC.Rename.Env ( + newTopSrcBinder, + lookupLocatedTopBndrRn, lookupTopBndrRn, + lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe, + lookupLocalOccRn_maybe, lookupInfoOccRn, + lookupLocalOccThLvl_maybe, lookupLocalOccRn, + lookupTypeOccRn, + lookupGlobalOccRn, lookupGlobalOccRn_maybe, + lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc, + + ChildLookupResult(..), + lookupSubBndrOcc_helper, + combineChildLookupResult, -- Called by lookupChildrenExport + + HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, + lookupSigCtxtOccRn, + + lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName, + lookupConstructorFields, + + lookupGreAvailRn, + + -- Rebindable Syntax + lookupSyntaxName, lookupSyntaxName', lookupSyntaxNames, + lookupIfThenElse, + + -- Constructing usage information + addUsedGRE, addUsedGREs, addUsedDataCons, + + + + dataTcOccs, --TODO: Move this somewhere, into utils? + + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Iface.Load ( loadInterfaceForName, loadSrcInterface_maybe ) +import GHC.Iface.Env +import GHC.Hs +import RdrName +import HscTypes +import TcEnv +import TcRnMonad +import RdrHsSyn ( filterCTuple, setRdrNameSpace ) +import TysWiredIn +import Name +import NameSet +import NameEnv +import Avail +import Module +import ConLike +import DataCon +import TyCon +import ErrUtils ( MsgDoc ) +import PrelNames ( rOOT_MAIN ) +import BasicTypes ( pprWarningTxtForMsg, TopLevelFlag(..)) +import SrcLoc +import Outputable +import UniqSet ( uniqSetAny ) +import Util +import Maybes +import DynFlags +import FastString +import Control.Monad +import ListSetOps ( minusList ) +import qualified GHC.LanguageExtensions as LangExt +import GHC.Rename.Unbound +import GHC.Rename.Utils +import qualified Data.Semigroup as Semi +import Data.Either ( partitionEithers ) +import Data.List (find) + +{- +********************************************************* +* * + Source-code binders +* * +********************************************************* + +Note [Signature lazy interface loading] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC's lazy interface loading can be a bit confusing, so this Note is an +empirical description of what happens in one interesting case. When +compiling a signature module against an its implementation, we do NOT +load interface files associated with its names until after the type +checking phase. For example: + + module ASig where + data T + f :: T -> T + +Suppose we compile this with -sig-of "A is ASig": + + module B where + data T = T + f T = T + + module A(module B) where + import B + +During type checking, we'll load A.hi because we need to know what the +RdrEnv for the module is, but we DO NOT load the interface for B.hi! +It's wholly unnecessary: our local definition 'data T' in ASig is all +the information we need to finish type checking. This is contrast to +type checking of ordinary Haskell files, in which we would not have the +local definition "data T" and would need to consult B.hi immediately. +(Also, this situation never occurs for hs-boot files, since you're not +allowed to reexport from another module.) + +After type checking, we then check that the types we provided are +consistent with the backing implementation (in checkHiBootOrHsigIface). +At this point, B.hi is loaded, because we need something to compare +against. + +I discovered this behavior when trying to figure out why type class +instances for Data.Map weren't in the EPS when I was type checking a +test very much like ASig (sigof02dm): the associated interface hadn't +been loaded yet! (The larger issue is a moot point, since an instance +declared in a signature can never be a duplicate.) + +This behavior might change in the future. Consider this +alternate module B: + + module B where + {-# DEPRECATED T, f "Don't use" #-} + data T = T + f T = T + +One might conceivably want to report deprecation warnings when compiling +ASig with -sig-of B, in which case we need to look at B.hi to find the +deprecation warnings during renaming. At the moment, you don't get any +warning until you use the identifier further downstream. This would +require adjusting addUsedGRE so that during signature compilation, +we do not report deprecation warnings for LocalDef. See also +Note [Handling of deprecations] +-} + +newTopSrcBinder :: Located RdrName -> RnM Name +newTopSrcBinder (L loc rdr_name) + | Just name <- isExact_maybe rdr_name + = -- This is here to catch + -- (a) Exact-name binders created by Template Haskell + -- (b) The PrelBase defn of (say) [] and similar, for which + -- the parser reads the special syntax and returns an Exact RdrName + -- We are at a binding site for the name, so check first that it + -- the current module is the correct one; otherwise GHC can get + -- very confused indeed. This test rejects code like + -- data T = (,) Int Int + -- unless we are in GHC.Tup + if isExternalName name then + do { this_mod <- getModule + ; unless (this_mod == nameModule name) + (addErrAt loc (badOrigBinding rdr_name)) + ; return name } + else -- See Note [Binders in Template Haskell] in Convert.hs + do { this_mod <- getModule + ; externaliseName this_mod name } + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { this_mod <- getModule + ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) + (addErrAt loc (badOrigBinding rdr_name)) + -- When reading External Core we get Orig names as binders, + -- but they should agree with the module gotten from the monad + -- + -- We can get built-in syntax showing up here too, sadly. If you type + -- data T = (,,,) + -- the constructor is parsed as a type, and then RdrHsSyn.tyConToDataCon + -- uses setRdrNameSpace to make it into a data constructors. At that point + -- the nice Exact name for the TyCon gets swizzled to an Orig name. + -- Hence the badOrigBinding error message. + -- + -- Except for the ":Main.main = ..." definition inserted into + -- the Main module; ugh! + + -- Because of this latter case, we call newGlobalBinder with a module from + -- the RdrName, not from the environment. In principle, it'd be fine to + -- have an arbitrary mixture of external core definitions in a single module, + -- (apart from module-initialisation issues, perhaps). + ; newGlobalBinder rdr_mod rdr_occ loc } + + | otherwise + = do { when (isQual rdr_name) + (addErrAt loc (badQualBndrErr rdr_name)) + -- Binders should not be qualified; if they are, and with a different + -- module name, we get a confusing "M.T is not in scope" error later + + ; stage <- getStage + ; if isBrackStage stage then + -- We are inside a TH bracket, so make an *Internal* name + -- See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names + do { uniq <- newUnique + ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } + else + do { this_mod <- getModule + ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr loc) + ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } + } + +{- +********************************************************* +* * + Source code occurrences +* * +********************************************************* + +Looking up a name in the GHC.Rename.Env. + +Note [Type and class operator definitions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to reject all of these unless we have -XTypeOperators (#3265) + data a :*: b = ... + class a :*: b where ... + data (:*:) a b = .... + class (:*:) a b where ... +The latter two mean that we are not just looking for a +*syntactically-infix* declaration, but one that uses an operator +OccName. We use OccName.isSymOcc to detect that case, which isn't +terribly efficient, but there seems to be no better way. +-} + +-- Can be made to not be exposed +-- Only used unwrapped in rnAnnProvenance +lookupTopBndrRn :: RdrName -> RnM Name +lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n + case nopt of + Just n' -> return n' + Nothing -> do traceRn "lookupTopBndrRn fail" (ppr n) + unboundName WL_LocalTop n + +lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) +lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn + +lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name) +-- Look up a top-level source-code binder. We may be looking up an unqualified 'f', +-- and there may be several imported 'f's too, which must not confuse us. +-- For example, this is OK: +-- import Foo( f ) +-- infix 9 f -- The 'f' here does not need to be qualified +-- f x = x -- Nor here, of course +-- So we have to filter out the non-local ones. +-- +-- A separate function (importsFromLocalDecls) reports duplicate top level +-- decls, so here it's safe just to choose an arbitrary one. +-- +-- There should never be a qualified name in a binding position in Haskell, +-- but there can be if we have read in an external-Core file. +-- The Haskell parser checks for the illegal qualified name in Haskell +-- source files, so we don't need to do so here. + +lookupTopBndrRn_maybe rdr_name = + lookupExactOrOrig rdr_name Just $ + do { -- Check for operators in type or class declarations + -- See Note [Type and class operator definitions] + let occ = rdrNameOcc rdr_name + ; when (isTcOcc occ && isSymOcc occ) + (do { op_ok <- xoptM LangExt.TypeOperators + ; unless op_ok (addErr (opDeclErr rdr_name)) }) + + ; env <- getGlobalRdrEnv + ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of + [gre] -> return (Just (gre_name gre)) + _ -> return Nothing -- Ambiguous (can't happen) or unbound + } + +----------------------------------------------- +-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. +-- This adds an error if the name cannot be found. +lookupExactOcc :: Name -> RnM Name +lookupExactOcc name + = do { result <- lookupExactOcc_either name + ; case result of + Left err -> do { addErr err + ; return name } + Right name' -> return name' } + +-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. +-- This never adds an error, but it may return one. +lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name) +-- See Note [Looking up Exact RdrNames] +lookupExactOcc_either name + | Just thing <- wiredInNameTyThing_maybe name + , Just tycon <- case thing of + ATyCon tc -> Just tc + AConLike (RealDataCon dc) -> Just (dataConTyCon dc) + _ -> Nothing + , isTupleTyCon tycon + = do { checkTupSize (tyConArity tycon) + ; return (Right name) } + + | isExternalName name + = return (Right name) + + | otherwise + = do { env <- getGlobalRdrEnv + ; let -- See Note [Splicing Exact names] + main_occ = nameOccName name + demoted_occs = case demoteOccName main_occ of + Just occ -> [occ] + Nothing -> [] + gres = [ gre | occ <- main_occ : demoted_occs + , gre <- lookupGlobalRdrEnv env occ + , gre_name gre == name ] + ; case gres of + [gre] -> return (Right (gre_name gre)) + + [] -> -- See Note [Splicing Exact names] + do { lcl_env <- getLocalRdrEnv + ; if name `inLocalRdrEnvScope` lcl_env + then return (Right name) + else + do { th_topnames_var <- fmap tcg_th_topnames getGblEnv + ; th_topnames <- readTcRef th_topnames_var + ; if name `elemNameSet` th_topnames + then return (Right name) + else return (Left exact_nm_err) + } + } + gres -> return (Left (sameNameErr gres)) -- Ugh! See Note [Template Haskell ambiguity] + } + where + exact_nm_err = hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope")) + 2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), " + , text "perhaps via newName, but did not bind it" + , text "If that's it, then -ddump-splices might be useful" ]) + +sameNameErr :: [GlobalRdrElt] -> MsgDoc +sameNameErr [] = panic "addSameNameErr: empty list" +sameNameErr gres@(_ : _) + = hang (text "Same exact name in multiple name-spaces:") + 2 (vcat (map pp_one sorted_names) $$ th_hint) + where + sorted_names = sortWith nameSrcLoc (map gre_name gres) + pp_one name + = hang (pprNameSpace (occNameSpace (getOccName name)) + <+> quotes (ppr name) <> comma) + 2 (text "declared at:" <+> ppr (nameSrcLoc name)) + + th_hint = vcat [ text "Probable cause: you bound a unique Template Haskell name (NameU)," + , text "perhaps via newName, in different name-spaces." + , text "If that's it, then -ddump-splices might be useful" ] + + +----------------------------------------------- +lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name +-- This is called on the method name on the left-hand side of an +-- instance declaration binding. eg. instance Functor T where +-- fmap = ... +-- ^^^^ called on this +-- Regardless of how many unqualified fmaps are in scope, we want +-- the one that comes from the Functor class. +-- +-- Furthermore, note that we take no account of whether the +-- name is only in scope qualified. I.e. even if method op is +-- in scope as M.op, we still allow plain 'op' on the LHS of +-- an instance decl +-- +-- The "what" parameter says "method" or "associated type", +-- depending on what we are looking up +lookupInstDeclBndr cls what rdr + = do { when (isQual rdr) + (addErr (badQualBndrErr rdr)) + -- In an instance decl you aren't allowed + -- to use a qualified name for the method + -- (Although it'd make perfect sense.) + ; mb_name <- lookupSubBndrOcc + False -- False => we don't give deprecated + -- warnings when a deprecated class + -- method is defined. We only warn + -- when it's used + cls doc rdr + ; case mb_name of + Left err -> do { addErr err; return (mkUnboundNameRdr rdr) } + Right nm -> return nm } + where + doc = what <+> text "of class" <+> quotes (ppr cls) + +----------------------------------------------- +lookupFamInstName :: Maybe Name -> Located RdrName + -> RnM (Located Name) +-- Used for TyData and TySynonym family instances only, +-- See Note [Family instance binders] +lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f GHC.Rename.Binds.rnMethodBind + = wrapLocM (lookupInstDeclBndr cls (text "associated type")) tc_rdr +lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* + = lookupLocatedOccRn tc_rdr + +----------------------------------------------- +lookupConstructorFields :: Name -> RnM [FieldLabel] +-- Look up the fields of a given constructor +-- * For constructors from this module, use the record field env, +-- which is itself gathered from the (as yet un-typechecked) +-- data type decls +-- +-- * For constructors from imported modules, use the *type* environment +-- since imported modles are already compiled, the info is conveniently +-- right there + +lookupConstructorFields con_name + = do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod con_name then + do { field_env <- getRecFieldEnv + ; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env) + ; return (lookupNameEnv field_env con_name `orElse` []) } + else + do { con <- tcLookupConLike con_name + ; traceTc "lookupCF 2" (ppr con) + ; return (conLikeFieldLabels con) } } + + +-- In CPS style as `RnM r` is monadic +lookupExactOrOrig :: RdrName -> (Name -> r) -> RnM r -> RnM r +lookupExactOrOrig rdr_name res k + | Just n <- isExact_maybe rdr_name -- This happens in derived code + = res <$> lookupExactOcc n + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = res <$> lookupOrig rdr_mod rdr_occ + | otherwise = k + + + +----------------------------------------------- +-- | Look up an occurrence of a field in record construction or pattern +-- matching (but not update). When the -XDisambiguateRecordFields +-- flag is on, take account of the data constructor name to +-- disambiguate which field to use. +-- +-- See Note [DisambiguateRecordFields]. +lookupRecFieldOcc :: Maybe Name -- Nothing => just look it up as usual + -- Just con => use data con to disambiguate + -> RdrName + -> RnM Name +lookupRecFieldOcc mb_con rdr_name + | Just con <- mb_con + , isUnboundName con -- Avoid error cascade + = return (mkUnboundNameRdr rdr_name) + | Just con <- mb_con + = do { flds <- lookupConstructorFields con + ; env <- getGlobalRdrEnv + ; let lbl = occNameFS (rdrNameOcc rdr_name) + mb_field = do fl <- find ((== lbl) . flLabel) flds + -- We have the label, now check it is in + -- scope (with the correct qualifier if + -- there is one, hence calling pickGREs). + gre <- lookupGRE_FieldLabel env fl + guard (not (isQual rdr_name + && null (pickGREs rdr_name [gre]))) + return (fl, gre) + ; case mb_field of + Just (fl, gre) -> do { addUsedGRE True gre + ; return (flSelector fl) } + Nothing -> lookupGlobalOccRn rdr_name } + -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc] + | otherwise + -- This use of Global is right as we are looking up a selector which + -- can only be defined at the top level. + = lookupGlobalOccRn rdr_name + +{- Note [DisambiguateRecordFields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are looking up record fields in record construction or pattern +matching, we can take advantage of the data constructor name to +resolve fields that would otherwise be ambiguous (provided the +-XDisambiguateRecordFields flag is on). + +For example, consider: + + data S = MkS { x :: Int } + data T = MkT { x :: Int } + + e = MkS { x = 3 } + +When we are renaming the occurrence of `x` in `e`, instead of looking +`x` up directly (and finding both fields), lookupRecFieldOcc will +search the fields of `MkS` to find the only possible `x` the user can +mean. + +Of course, we still have to check the field is in scope, using +lookupGRE_FieldLabel. The handling of qualified imports is slightly +subtle: the occurrence may be unqualified even if the field is +imported only qualified (but if the occurrence is qualified, the +qualifier must be correct). For example: + + module A where + data S = MkS { x :: Int } + data T = MkT { x :: Int } + + module B where + import qualified A (S(..)) + import A (T(MkT)) + + e1 = MkT { x = 3 } -- x not in scope, so fail + e2 = A.MkS { B.x = 3 } -- module qualifier is wrong, so fail + e3 = A.MkS { x = 3 } -- x in scope (lack of module qualifier permitted) + +In case `e1`, lookupGRE_FieldLabel will return Nothing. In case `e2`, +lookupGRE_FieldLabel will return the GRE for `A.x`, but then the guard +will fail because the field RdrName `B.x` is qualified and pickGREs +rejects the GRE. In case `e3`, lookupGRE_FieldLabel will return the +GRE for `A.x` and the guard will succeed because the field RdrName `x` +is unqualified. + + +Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Whenever we fail to find the field or it is not in scope, mb_field +will be False, and we fall back on looking it up normally using +lookupGlobalOccRn. We don't report an error immediately because the +actual problem might be located elsewhere. For example (#9975): + + data Test = Test { x :: Int } + pattern Test wat = Test { x = wat } + +Here there are multiple declarations of Test (as a data constructor +and as a pattern synonym), which will be reported as an error. We +shouldn't also report an error about the occurrence of `x` in the +pattern synonym RHS. However, if the pattern synonym gets added to +the environment first, we will try and fail to find `x` amongst the +(nonexistent) fields of the pattern synonym. + +Alternatively, the scope check can fail due to Template Haskell. +Consider (#12130): + + module Foo where + import M + b = $(funny) + + module M(funny) where + data T = MkT { x :: Int } + funny :: Q Exp + funny = [| MkT { x = 3 } |] + +When we splice, `MkT` is not lexically in scope, so +lookupGRE_FieldLabel will fail. But there is no need for +disambiguation anyway, because `x` is an original name, and +lookupGlobalOccRn will find it. +-} + + + +-- | Used in export lists to lookup the children. +lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName + -> RnM ChildLookupResult +lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name + | isUnboundName parent + -- Avoid an error cascade + = return (FoundName NoParent (mkUnboundNameRdr rdr_name)) + + | otherwise = do + gre_env <- getGlobalRdrEnv + + let original_gres = lookupGlobalRdrEnv gre_env (rdrNameOcc rdr_name) + -- Disambiguate the lookup based on the parent information. + -- The remaining GREs are things that we *could* export here, note that + -- this includes things which have `NoParent`. Those are sorted in + -- `checkPatSynParent`. + traceRn "parent" (ppr parent) + traceRn "lookupExportChild original_gres:" (ppr original_gres) + traceRn "lookupExportChild picked_gres:" (ppr $ picked_gres original_gres) + case picked_gres original_gres of + NoOccurrence -> + noMatchingParentErr original_gres + UniqueOccurrence g -> + if must_have_parent then noMatchingParentErr original_gres + else checkFld g + DisambiguatedOccurrence g -> + checkFld g + AmbiguousOccurrence gres -> + mkNameClashErr gres + where + -- Convert into FieldLabel if necessary + checkFld :: GlobalRdrElt -> RnM ChildLookupResult + checkFld g@GRE{gre_name, gre_par} = do + addUsedGRE warn_if_deprec g + return $ case gre_par of + FldParent _ mfs -> + FoundFL (fldParentToFieldLabel gre_name mfs) + _ -> FoundName gre_par gre_name + + fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel + fldParentToFieldLabel name mfs = + case mfs of + Nothing -> + let fs = occNameFS (nameOccName name) + in FieldLabel fs False name + Just fs -> FieldLabel fs True name + + -- Called when we find no matching GREs after disambiguation but + -- there are three situations where this happens. + -- 1. There were none to begin with. + -- 2. None of the matching ones were the parent but + -- a. They were from an overloaded record field so we can report + -- a better error + -- b. The original lookup was actually ambiguous. + -- For example, the case where overloading is off and two + -- record fields are in scope from different record + -- constructors, neither of which is the parent. + noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult + noMatchingParentErr original_gres = do + overload_ok <- xoptM LangExt.DuplicateRecordFields + case original_gres of + [] -> return NameNotFound + [g] -> return $ IncorrectParent parent + (gre_name g) (ppr $ gre_name g) + [p | Just p <- [getParent g]] + gss@(g:_:_) -> + if all isRecFldGRE gss && overload_ok + then return $ + IncorrectParent parent + (gre_name g) + (ppr $ expectJust "noMatchingParentErr" (greLabel g)) + [p | x <- gss, Just p <- [getParent x]] + else mkNameClashErr gss + + mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult + mkNameClashErr gres = do + addNameClashErrRn rdr_name gres + return (FoundName (gre_par (head gres)) (gre_name (head gres))) + + getParent :: GlobalRdrElt -> Maybe Name + getParent (GRE { gre_par = p } ) = + case p of + ParentIs cur_parent -> Just cur_parent + FldParent { par_is = cur_parent } -> Just cur_parent + NoParent -> Nothing + + picked_gres :: [GlobalRdrElt] -> DisambigInfo + -- For Unqual, find GREs that are in scope qualified or unqualified + -- For Qual, find GREs that are in scope with that qualification + picked_gres gres + | isUnqual rdr_name + = mconcat (map right_parent gres) + | otherwise + = mconcat (map right_parent (pickGREs rdr_name gres)) + + right_parent :: GlobalRdrElt -> DisambigInfo + right_parent p + = case getParent p of + Just cur_parent + | parent == cur_parent -> DisambiguatedOccurrence p + | otherwise -> NoOccurrence + Nothing -> UniqueOccurrence p + + +-- This domain specific datatype is used to record why we decided it was +-- possible that a GRE could be exported with a parent. +data DisambigInfo + = NoOccurrence + -- The GRE could never be exported. It has the wrong parent. + | UniqueOccurrence GlobalRdrElt + -- The GRE has no parent. It could be a pattern synonym. + | DisambiguatedOccurrence GlobalRdrElt + -- The parent of the GRE is the correct parent + | AmbiguousOccurrence [GlobalRdrElt] + -- For example, two normal identifiers with the same name are in + -- scope. They will both be resolved to "UniqueOccurrence" and the + -- monoid will combine them to this failing case. + +instance Outputable DisambigInfo where + ppr NoOccurrence = text "NoOccurence" + ppr (UniqueOccurrence gre) = text "UniqueOccurrence:" <+> ppr gre + ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre + ppr (AmbiguousOccurrence gres) = text "Ambiguous:" <+> ppr gres + +instance Semi.Semigroup DisambigInfo where + -- This is the key line: We prefer disambiguated occurrences to other + -- names. + _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g' + DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g' + + NoOccurrence <> m = m + m <> NoOccurrence = m + UniqueOccurrence g <> UniqueOccurrence g' + = AmbiguousOccurrence [g, g'] + UniqueOccurrence g <> AmbiguousOccurrence gs + = AmbiguousOccurrence (g:gs) + AmbiguousOccurrence gs <> UniqueOccurrence g' + = AmbiguousOccurrence (g':gs) + AmbiguousOccurrence gs <> AmbiguousOccurrence gs' + = AmbiguousOccurrence (gs ++ gs') + +instance Monoid DisambigInfo where + mempty = NoOccurrence + mappend = (Semi.<>) + +-- Lookup SubBndrOcc can never be ambiguous +-- +-- Records the result of looking up a child. +data ChildLookupResult + = NameNotFound -- We couldn't find a suitable name + | IncorrectParent Name -- Parent + Name -- Name of thing we were looking for + SDoc -- How to print the name + [Name] -- List of possible parents + | FoundName Parent Name -- We resolved to a normal name + | FoundFL FieldLabel -- We resolved to a FL + +-- | Specialised version of msum for RnM ChildLookupResult +combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult +combineChildLookupResult [] = return NameNotFound +combineChildLookupResult (x:xs) = do + res <- x + case res of + NameNotFound -> combineChildLookupResult xs + _ -> return res + +instance Outputable ChildLookupResult where + ppr NameNotFound = text "NameNotFound" + ppr (FoundName p n) = text "Found:" <+> ppr p <+> ppr n + ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls + ppr (IncorrectParent p n td ns) = text "IncorrectParent" + <+> hsep [ppr p, ppr n, td, ppr ns] + +lookupSubBndrOcc :: Bool + -> Name -- Parent + -> SDoc + -> RdrName + -> RnM (Either MsgDoc Name) +-- Find all the things the rdr-name maps to +-- and pick the one with the right parent namep +lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do + res <- + lookupExactOrOrig rdr_name (FoundName NoParent) $ + -- This happens for built-in classes, see mod052 for example + lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name + case res of + NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name)) + FoundName _p n -> return (Right n) + FoundFL fl -> return (Right (flSelector fl)) + IncorrectParent {} + -- See [Mismatched class methods and associated type families] + -- in TcInstDecls. + -> return $ Left (unknownSubordinateErr doc rdr_name) + +{- +Note [Family instance binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family F a + data instance F T = X1 | X2 + +The 'data instance' decl has an *occurrence* of F (and T), and *binds* +X1 and X2. (This is unlike a normal data type declaration which would +bind F too.) So we want an AvailTC F [X1,X2]. + +Now consider a similar pair: + class C a where + data G a + instance C S where + data G S = Y1 | Y2 + +The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G. + +But there is a small complication: in an instance decl, we don't use +qualified names on the LHS; instead we use the class to disambiguate. +Thus: + module M where + import Blib( G ) + class C a where + data G a + instance C S where + data G S = Y1 | Y2 +Even though there are two G's in scope (M.G and Blib.G), the occurrence +of 'G' in the 'instance C S' decl is unambiguous, because C has only +one associated type called G. This is exactly what happens for methods, +and it is only consistent to do the same thing for types. That's the +role of the function lookupTcdName; the (Maybe Name) give the class of +the encloseing instance decl, if any. + +Note [Looking up Exact RdrNames] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Exact RdrNames are generated by Template Haskell. See Note [Binders +in Template Haskell] in Convert. + +For data types and classes have Exact system Names in the binding +positions for constructors, TyCons etc. For example + [d| data T = MkT Int |] +when we splice in and Convert to HsSyn RdrName, we'll get + data (Exact (system Name "T")) = (Exact (system Name "MkT")) ... +These System names are generated by Convert.thRdrName + +But, constructors and the like need External Names, not System Names! +So we do the following + + * In GHC.Rename.Env.newTopSrcBinder we spot Exact RdrNames that wrap a + non-External Name, and make an External name for it. This is + the name that goes in the GlobalRdrEnv + + * When looking up an occurrence of an Exact name, done in + GHC.Rename.Env.lookupExactOcc, we find the Name with the right unique in the + GlobalRdrEnv, and use the one from the envt -- it will be an + External Name in the case of the data type/constructor above. + + * Exact names are also use for purely local binders generated + by TH, such as \x_33. x_33 + Both binder and occurrence are Exact RdrNames. The occurrence + gets looked up in the LocalRdrEnv by GHC.Rename.Env.lookupOccRn, and + misses, because lookupLocalRdrEnv always returns Nothing for + an Exact Name. Now we fall through to lookupExactOcc, which + will find the Name is not in the GlobalRdrEnv, so we just use + the Exact supplied Name. + +Note [Splicing Exact names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the splice $(do { x <- newName "x"; return (VarE x) }) +This will generate a (HsExpr RdrName) term that mentions the +Exact RdrName "x_56" (or whatever), but does not bind it. So +when looking such Exact names we want to check that it's in scope, +otherwise the type checker will get confused. To do this we need to +keep track of all the Names in scope, and the LocalRdrEnv does just that; +we consult it with RdrName.inLocalRdrEnvScope. + +There is another wrinkle. With TH and -XDataKinds, consider + $( [d| data Nat = Zero + data T = MkT (Proxy 'Zero) |] ) +After splicing, but before renaming we get this: + data Nat_77{tc} = Zero_78{d} + data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc}) |] ) +The occurrence of 'Zero in the data type for T has the right unique, +but it has a TcClsName name-space in its OccName. (This is set by +the ctxt_ns argument of Convert.thRdrName.) When we check that is +in scope in the GlobalRdrEnv, we need to look up the DataName namespace +too. (An alternative would be to make the GlobalRdrEnv also have +a Name -> GRE mapping.) + +Note [Template Haskell ambiguity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The GlobalRdrEnv invariant says that if + occ -> [gre1, ..., gren] +then the gres have distinct Names (INVARIANT 1 of GlobalRdrEnv). +This is guaranteed by extendGlobalRdrEnvRn (the dups check in add_gre). + +So how can we get multiple gres in lookupExactOcc_maybe? Because in +TH we might use the same TH NameU in two different name spaces. +eg (#7241): + $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]]) +Here we generate a type constructor and data constructor with the same +unique, but different name spaces. + +It'd be nicer to rule this out in extendGlobalRdrEnvRn, but that would +mean looking up the OccName in every name-space, just in case, and that +seems a bit brutal. So it's just done here on lookup. But we might +need to revisit that choice. + +Note [Usage for sub-bndrs] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you have this + import qualified M( C( f ) ) + instance M.C T where + f x = x +then is the qualified import M.f used? Obviously yes. +But the RdrName used in the instance decl is unqualified. In effect, +we fill in the qualification by looking for f's whose class is M.C +But when adding to the UsedRdrNames we must make that qualification +explicit (saying "used M.f"), otherwise we get "Redundant import of M.f". + +So we make up a suitable (fake) RdrName. But be careful + import qualified M + import M( C(f) ) + instance C T where + f x = x +Here we want to record a use of 'f', not of 'M.f', otherwise +we'll miss the fact that the qualified import is redundant. + +-------------------------------------------------- +-- Occurrences +-------------------------------------------------- +-} + + +lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) +lookupLocatedOccRn = wrapLocM lookupOccRn + +lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name) +-- Just look in the local environment +lookupLocalOccRn_maybe rdr_name + = do { local_env <- getLocalRdrEnv + ; return (lookupLocalRdrEnv local_env rdr_name) } + +lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel)) +-- Just look in the local environment +lookupLocalOccThLvl_maybe name + = do { lcl_env <- getLclEnv + ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) } + +-- lookupOccRn looks up an occurrence of a RdrName +lookupOccRn :: RdrName -> RnM Name +lookupOccRn rdr_name + = do { mb_name <- lookupOccRn_maybe rdr_name + ; case mb_name of + Just name -> return name + Nothing -> reportUnboundName rdr_name } + +-- Only used in one place, to rename pattern synonym binders. +-- See Note [Renaming pattern synonym variables] in GHC.Rename.Binds +lookupLocalOccRn :: RdrName -> RnM Name +lookupLocalOccRn rdr_name + = do { mb_name <- lookupLocalOccRn_maybe rdr_name + ; case mb_name of + Just name -> return name + Nothing -> unboundName WL_LocalOnly rdr_name } + +-- lookupPromotedOccRn looks up an optionally promoted RdrName. +lookupTypeOccRn :: RdrName -> RnM Name +-- see Note [Demotion] +lookupTypeOccRn rdr_name + | isVarOcc (rdrNameOcc rdr_name) -- See Note [Promoted variables in types] + = badVarInType rdr_name + | otherwise + = do { mb_name <- lookupOccRn_maybe rdr_name + ; case mb_name of + Just name -> return name + Nothing -> lookup_demoted rdr_name } + +lookup_demoted :: RdrName -> RnM Name +lookup_demoted rdr_name + | Just demoted_rdr <- demoteRdrName rdr_name + -- Maybe it's the name of a *data* constructor + = do { data_kinds <- xoptM LangExt.DataKinds + ; star_is_type <- xoptM LangExt.StarIsType + ; let star_info = starInfo star_is_type rdr_name + ; if data_kinds + then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr + ; case mb_demoted_name of + Nothing -> unboundNameX WL_Any rdr_name star_info + Just demoted_name -> + do { whenWOptM Opt_WarnUntickedPromotedConstructors $ + addWarn + (Reason Opt_WarnUntickedPromotedConstructors) + (untickedPromConstrWarn demoted_name) + ; return demoted_name } } + else do { -- We need to check if a data constructor of this name is + -- in scope to give good error messages. However, we do + -- not want to give an additional error if the data + -- constructor happens to be out of scope! See #13947. + mb_demoted_name <- discardErrs $ + lookupOccRn_maybe demoted_rdr + ; let suggestion | isJust mb_demoted_name = suggest_dk + | otherwise = star_info + ; unboundNameX WL_Any rdr_name suggestion } } + + | otherwise + = reportUnboundName rdr_name + + where + suggest_dk = text "A data constructor of that name is in scope; did you mean DataKinds?" + untickedPromConstrWarn name = + text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot + $$ + hsep [ text "Use" + , quotes (char '\'' <> ppr name) + , text "instead of" + , quotes (ppr name) <> dot ] + +badVarInType :: RdrName -> RnM Name +badVarInType rdr_name + = do { addErr (text "Illegal promoted term variable in a type:" + <+> ppr rdr_name) + ; return (mkUnboundNameRdr rdr_name) } + +{- Note [Promoted variables in types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (#12686): + x = True + data Bad = Bad 'x + +The parser treats the quote in 'x as saying "use the term +namespace", so we'll get (Bad x{v}), with 'x' in the +VarName namespace. If we don't test for this, the renamer +will happily rename it to the x bound at top level, and then +the typecheck falls over because it doesn't have 'x' in scope +when kind-checking. + +Note [Demotion] +~~~~~~~~~~~~~~~ +When the user writes: + data Nat = Zero | Succ Nat + foo :: f Zero -> Int + +'Zero' in the type signature of 'foo' is parsed as: + HsTyVar ("Zero", TcClsName) + +When the renamer hits this occurrence of 'Zero' it's going to realise +that it's not in scope. But because it is renaming a type, it knows +that 'Zero' might be a promoted data constructor, so it will demote +its namespace to DataName and do a second lookup. + +The final result (after the renamer) will be: + HsTyVar ("Zero", DataName) +-} + +lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (Name -> r) -> RdrName + -> RnM (Maybe r) +lookupOccRnX_maybe globalLookup wrapper rdr_name + = runMaybeT . msum . map MaybeT $ + [ fmap wrapper <$> lookupLocalOccRn_maybe rdr_name + , globalLookup rdr_name ] + +lookupOccRn_maybe :: RdrName -> RnM (Maybe Name) +lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id + +lookupOccRn_overloaded :: Bool -> RdrName + -> RnM (Maybe (Either Name [Name])) +lookupOccRn_overloaded overload_ok + = lookupOccRnX_maybe global_lookup Left + where + global_lookup :: RdrName -> RnM (Maybe (Either Name [Name])) + global_lookup n = + runMaybeT . msum . map MaybeT $ + [ lookupGlobalOccRn_overloaded overload_ok n + , fmap Left . listToMaybe <$> lookupQualifiedNameGHCi n ] + + + +lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) +-- Looks up a RdrName occurrence in the top-level +-- environment, including using lookupQualifiedNameGHCi +-- for the GHCi case +-- No filter function; does not report an error on failure +-- Uses addUsedRdrName to record use and deprecations +lookupGlobalOccRn_maybe rdr_name = + lookupExactOrOrig rdr_name Just $ + runMaybeT . msum . map MaybeT $ + [ fmap gre_name <$> lookupGreRn_maybe rdr_name + , listToMaybe <$> lookupQualifiedNameGHCi rdr_name ] + -- This test is not expensive, + -- and only happens for failed lookups + +lookupGlobalOccRn :: RdrName -> RnM Name +-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global +-- environment. Adds an error message if the RdrName is not in scope. +-- You usually want to use "lookupOccRn" which also looks in the local +-- environment. +lookupGlobalOccRn rdr_name + = do { mb_name <- lookupGlobalOccRn_maybe rdr_name + ; case mb_name of + Just n -> return n + Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name) + ; unboundName WL_Global rdr_name } } + +lookupInfoOccRn :: RdrName -> RnM [Name] +-- lookupInfoOccRn is intended for use in GHCi's ":info" command +-- It finds all the GREs that RdrName could mean, not complaining +-- about ambiguity, but rather returning them all +-- C.f. #9881 +lookupInfoOccRn rdr_name = + lookupExactOrOrig rdr_name (:[]) $ + do { rdr_env <- getGlobalRdrEnv + ; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env) + ; qual_ns <- lookupQualifiedNameGHCi rdr_name + ; return (ns ++ (qual_ns `minusList` ns)) } + +-- | Like 'lookupOccRn_maybe', but with a more informative result if +-- the 'RdrName' happens to be a record selector: +-- +-- * Nothing -> name not in scope (no error reported) +-- * Just (Left x) -> name uniquely refers to x, +-- or there is a name clash (reported) +-- * Just (Right xs) -> name refers to one or more record selectors; +-- if overload_ok was False, this list will be +-- a singleton. + +lookupGlobalOccRn_overloaded :: Bool -> RdrName + -> RnM (Maybe (Either Name [Name])) +lookupGlobalOccRn_overloaded overload_ok rdr_name = + lookupExactOrOrig rdr_name (Just . Left) $ + do { res <- lookupGreRn_helper rdr_name + ; case res of + GreNotFound -> return Nothing + OneNameMatch gre -> do + let wrapper = if isRecFldGRE gre then Right . (:[]) else Left + return $ Just (wrapper (gre_name gre)) + MultipleNames gres | all isRecFldGRE gres && overload_ok -> + -- Don't record usage for ambiguous selectors + -- until we know which is meant + return $ Just (Right (map gre_name gres)) + MultipleNames gres -> do + addNameClashErrRn rdr_name gres + return (Just (Left (gre_name (head gres)))) } + + +-------------------------------------------------- +-- Lookup in the Global RdrEnv of the module +-------------------------------------------------- + +data GreLookupResult = GreNotFound + | OneNameMatch GlobalRdrElt + | MultipleNames [GlobalRdrElt] + +lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) +-- Look up the RdrName in the GlobalRdrEnv +-- Exactly one binding: records it as "used", return (Just gre) +-- No bindings: return Nothing +-- Many bindings: report "ambiguous", return an arbitrary (Just gre) +-- Uses addUsedRdrName to record use and deprecations +lookupGreRn_maybe rdr_name + = do + res <- lookupGreRn_helper rdr_name + case res of + OneNameMatch gre -> return $ Just gre + MultipleNames gres -> do + traceRn "lookupGreRn_maybe:NameClash" (ppr gres) + addNameClashErrRn rdr_name gres + return $ Just (head gres) + GreNotFound -> return Nothing + +{- + +Note [ Unbound vs Ambiguous Names ] + +lookupGreRn_maybe deals with failures in two different ways. If a name +is unbound then we return a `Nothing` but if the name is ambiguous +then we raise an error and return a dummy name. + +The reason for this is that when we call `lookupGreRn_maybe` we are +speculatively looking for whatever we are looking up. If we don't find it, +then we might have been looking for the wrong thing and can keep trying. +On the other hand, if we find a clash then there is no way to recover as +we found the thing we were looking for but can no longer resolve which +the correct one is. + +One example of this is in `lookupTypeOccRn` which first looks in the type +constructor namespace before looking in the data constructor namespace to +deal with `DataKinds`. + +There is however, as always, one exception to this scheme. If we find +an ambiguous occurrence of a record selector and DuplicateRecordFields +is enabled then we defer the selection until the typechecker. + +-} + + + + +-- Internal Function +lookupGreRn_helper :: RdrName -> RnM GreLookupResult +lookupGreRn_helper rdr_name + = do { env <- getGlobalRdrEnv + ; case lookupGRE_RdrName rdr_name env of + [] -> return GreNotFound + [gre] -> do { addUsedGRE True gre + ; return (OneNameMatch gre) } + gres -> return (MultipleNames gres) } + +lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo) +-- Used in export lists +-- If not found or ambiguous, add error message, and fake with UnboundName +-- Uses addUsedRdrName to record use and deprecations +lookupGreAvailRn rdr_name + = do + mb_gre <- lookupGreRn_helper rdr_name + case mb_gre of + GreNotFound -> + do + traceRn "lookupGreAvailRn" (ppr rdr_name) + name <- unboundName WL_Global rdr_name + return (name, avail name) + MultipleNames gres -> + do + addNameClashErrRn rdr_name gres + let unbound_name = mkUnboundNameRdr rdr_name + return (unbound_name, avail unbound_name) + -- Returning an unbound name here prevents an error + -- cascade + OneNameMatch gre -> + return (gre_name gre, availFromGRE gre) + + +{- +********************************************************* +* * + Deprecations +* * +********************************************************* + +Note [Handling of deprecations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* We report deprecations at each *occurrence* of the deprecated thing + (see #5867) + +* We do not report deprecations for locally-defined names. For a + start, we may be exporting a deprecated thing. Also we may use a + deprecated thing in the defn of another deprecated things. We may + even use a deprecated thing in the defn of a non-deprecated thing, + when changing a module's interface. + +* addUsedGREs: we do not report deprecations for sub-binders: + - the ".." completion for records + - the ".." in an export item 'T(..)' + - the things exported by a module export 'module M' +-} + +addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM () +-- Remember use of in-scope data constructors (#7969) +addUsedDataCons rdr_env tycon + = addUsedGREs [ gre + | dc <- tyConDataCons tycon + , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ] + +addUsedGRE :: Bool -> GlobalRdrElt -> RnM () +-- Called for both local and imported things +-- Add usage *and* warn if deprecated +addUsedGRE warn_if_deprec gre + = do { when warn_if_deprec (warnIfDeprecated gre) + ; unless (isLocalGRE gre) $ + do { env <- getGblEnv + ; traceRn "addUsedGRE" (ppr gre) + ; updMutVar (tcg_used_gres env) (gre :) } } + +addUsedGREs :: [GlobalRdrElt] -> RnM () +-- Record uses of any *imported* GREs +-- Used for recording used sub-bndrs +-- NB: no call to warnIfDeprecated; see Note [Handling of deprecations] +addUsedGREs gres + | null imp_gres = return () + | otherwise = do { env <- getGblEnv + ; traceRn "addUsedGREs" (ppr imp_gres) + ; updMutVar (tcg_used_gres env) (imp_gres ++) } + where + imp_gres = filterOut isLocalGRE gres + +warnIfDeprecated :: GlobalRdrElt -> RnM () +warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss }) + | (imp_spec : _) <- iss + = do { dflags <- getDynFlags + ; this_mod <- getModule + ; when (wopt Opt_WarnWarningsDeprecations dflags && + not (nameIsLocalOrFrom this_mod name)) $ + -- See Note [Handling of deprecations] + do { iface <- loadInterfaceForName doc name + ; case lookupImpDeprec iface gre of + Just txt -> addWarn (Reason Opt_WarnWarningsDeprecations) + (mk_msg imp_spec txt) + Nothing -> return () } } + | otherwise + = return () + where + occ = greOccName gre + name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name + doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly") + + mk_msg imp_spec txt + = sep [ sep [ text "In the use of" + <+> pprNonVarNameSpace (occNameSpace occ) + <+> quotes (ppr occ) + , parens imp_msg <> colon ] + , pprWarningTxtForMsg txt ] + where + imp_mod = importSpecModule imp_spec + imp_msg = text "imported from" <+> ppr imp_mod <> extra + extra | imp_mod == moduleName name_mod = Outputable.empty + | otherwise = text ", but defined in" <+> ppr name_mod + +lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt +lookupImpDeprec iface gre + = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus` -- Bleat if the thing, + case gre_par gre of -- or its parent, is warn'd + ParentIs p -> mi_warn_fn (mi_final_exts iface) (nameOccName p) + FldParent { par_is = p } -> mi_warn_fn (mi_final_exts iface) (nameOccName p) + NoParent -> Nothing + +{- +Note [Used names with interface not loaded] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's (just) possible to find a used +Name whose interface hasn't been loaded: + +a) It might be a WiredInName; in that case we may not load + its interface (although we could). + +b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger + These are seen as "used" by the renamer (if -XRebindableSyntax) + is on), but the typechecker may discard their uses + if in fact the in-scope fromRational is GHC.Read.fromRational, + (see tcPat.tcOverloadedLit), and the typechecker sees that the type + is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst). + In that obscure case it won't force the interface in. + +In both cases we simply don't permit deprecations; +this is, after all, wired-in stuff. + + +********************************************************* +* * + GHCi support +* * +********************************************************* + +A qualified name on the command line can refer to any module at +all: we try to load the interface if we don't already have it, just +as if there was an "import qualified M" declaration for every +module. + +For example, writing `Data.List.sort` will load the interface file for +`Data.List` as if the user had written `import qualified Data.List`. + +If we fail we just return Nothing, rather than bleating +about "attempting to use module ‘D’ (./D.hs) which is not loaded" +which is what loadSrcInterface does. + +It is enabled by default and disabled by the flag +`-fno-implicit-import-qualified`. + +Note [Safe Haskell and GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We DON'T do this Safe Haskell as we need to check imports. We can +and should instead check the qualified import but at the moment +this requires some refactoring so leave as a TODO +-} + + + +lookupQualifiedNameGHCi :: RdrName -> RnM [Name] +lookupQualifiedNameGHCi rdr_name + = -- We want to behave as we would for a source file import here, + -- and respect hiddenness of modules/packages, hence loadSrcInterface. + do { dflags <- getDynFlags + ; is_ghci <- getIsGHCi + ; go_for_it dflags is_ghci } + + where + go_for_it dflags is_ghci + | Just (mod,occ) <- isQual_maybe rdr_name + , is_ghci + , gopt Opt_ImplicitImportQualified dflags -- Enables this GHCi behaviour + , not (safeDirectImpsReq dflags) -- See Note [Safe Haskell and GHCi] + = do { res <- loadSrcInterface_maybe doc mod False Nothing + ; case res of + Succeeded iface + -> return [ name + | avail <- mi_exports iface + , name <- availNames avail + , nameOccName name == occ ] + + _ -> -- Either we couldn't load the interface, or + -- we could but we didn't find the name in it + do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name) + ; return [] } } + + | otherwise + = do { traceRn "lookupQualifiedNameGHCi: off" (ppr rdr_name) + ; return [] } + + doc = text "Need to find" <+> ppr rdr_name + +{- +Note [Looking up signature names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +lookupSigOccRn is used for type signatures and pragmas +Is this valid? + module A + import M( f ) + f :: Int -> Int + f x = x +It's clear that the 'f' in the signature must refer to A.f +The Haskell98 report does not stipulate this, but it will! +So we must treat the 'f' in the signature in the same way +as the binding occurrence of 'f', using lookupBndrRn + +However, consider this case: + import M( f ) + f :: Int -> Int + g x = x +We don't want to say 'f' is out of scope; instead, we want to +return the imported 'f', so that later on the renamer will +correctly report "misplaced type sig". + +Note [Signatures for top level things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +data HsSigCtxt = ... | TopSigCtxt NameSet | .... + +* The NameSet says what is bound in this group of bindings. + We can't use isLocalGRE from the GlobalRdrEnv, because of this: + f x = x + $( ...some TH splice... ) + f :: Int -> Int + When we encounter the signature for 'f', the binding for 'f' + will be in the GlobalRdrEnv, and will be a LocalDef. Yet the + signature is mis-placed + +* For type signatures the NameSet should be the names bound by the + value bindings; for fixity declarations, the NameSet should also + include class sigs and record selectors + + infix 3 `f` -- Yes, ok + f :: C a => a -> a -- No, not ok + class C a where + f :: a -> a +-} + +data HsSigCtxt + = TopSigCtxt NameSet -- At top level, binding these names + -- See Note [Signatures for top level things] + | LocalBindCtxt NameSet -- In a local binding, binding these names + | ClsDeclCtxt Name -- Class decl for this class + | InstDeclCtxt NameSet -- Instance decl whose user-written method + -- bindings are for these methods + | HsBootCtxt NameSet -- Top level of a hs-boot file, binding these names + | RoleAnnotCtxt NameSet -- A role annotation, with the names of all types + -- in the group + +instance Outputable HsSigCtxt where + ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns + ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns + ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n + ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns + ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns + ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns + +lookupSigOccRn :: HsSigCtxt + -> Sig GhcPs + -> Located RdrName -> RnM (Located Name) +lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig) + +-- | Lookup a name in relation to the names in a 'HsSigCtxt' +lookupSigCtxtOccRn :: HsSigCtxt + -> SDoc -- ^ description of thing we're looking up, + -- like "type family" + -> Located RdrName -> RnM (Located Name) +lookupSigCtxtOccRn ctxt what + = wrapLocM $ \ rdr_name -> + do { mb_name <- lookupBindGroupOcc ctxt what rdr_name + ; case mb_name of + Left err -> do { addErr err; return (mkUnboundNameRdr rdr_name) } + Right name -> return name } + +lookupBindGroupOcc :: HsSigCtxt + -> SDoc + -> RdrName -> RnM (Either MsgDoc Name) +-- Looks up the RdrName, expecting it to resolve to one of the +-- bound names passed in. If not, return an appropriate error message +-- +-- See Note [Looking up signature names] +lookupBindGroupOcc ctxt what rdr_name + | Just n <- isExact_maybe rdr_name + = lookupExactOcc_either n -- allow for the possibility of missing Exacts; + -- see Note [dataTcOccs and Exact Names] + -- Maybe we should check the side conditions + -- but it's a pain, and Exact things only show + -- up when you know what you are doing + + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = do { n' <- lookupOrig rdr_mod rdr_occ + ; return (Right n') } + + | otherwise + = case ctxt of + HsBootCtxt ns -> lookup_top (`elemNameSet` ns) + TopSigCtxt ns -> lookup_top (`elemNameSet` ns) + RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns) + LocalBindCtxt ns -> lookup_group ns + ClsDeclCtxt cls -> lookup_cls_op cls + InstDeclCtxt ns -> if uniqSetAny isUnboundName ns -- #16610 + then return (Right $ mkUnboundNameRdr rdr_name) + else lookup_top (`elemNameSet` ns) + where + lookup_cls_op cls + = lookupSubBndrOcc True cls doc rdr_name + where + doc = text "method of class" <+> quotes (ppr cls) + + lookup_top keep_me + = do { env <- getGlobalRdrEnv + ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) + names_in_scope = -- If rdr_name lacks a binding, only + -- recommend alternatives from related + -- namespaces. See #17593. + filter (\n -> nameSpacesRelated + (rdrNameSpace rdr_name) + (nameNameSpace n)) + $ map gre_name + $ filter isLocalGRE + $ globalRdrEnvElts env + candidates_msg = candidates names_in_scope + ; case filter (keep_me . gre_name) all_gres of + [] | null all_gres -> bale_out_with candidates_msg + | otherwise -> bale_out_with local_msg + (gre:_) -> return (Right (gre_name gre)) } + + lookup_group bound_names -- Look in the local envt (not top level) + = do { mname <- lookupLocalOccRn_maybe rdr_name + ; env <- getLocalRdrEnv + ; let candidates_msg = candidates $ localRdrEnvElts env + ; case mname of + Just n + | n `elemNameSet` bound_names -> return (Right n) + | otherwise -> bale_out_with local_msg + Nothing -> bale_out_with candidates_msg } + + bale_out_with msg + = return (Left (sep [ text "The" <+> what + <+> text "for" <+> quotes (ppr rdr_name) + , nest 2 $ text "lacks an accompanying binding"] + $$ nest 2 msg)) + + local_msg = parens $ text "The" <+> what <+> ptext (sLit "must be given where") + <+> quotes (ppr rdr_name) <+> text "is declared" + + -- Identify all similar names and produce a message listing them + candidates :: [Name] -> MsgDoc + candidates names_in_scope + = case similar_names of + [] -> Outputable.empty + [n] -> text "Perhaps you meant" <+> pp_item n + _ -> sep [ text "Perhaps you meant one of these:" + , nest 2 (pprWithCommas pp_item similar_names) ] + where + similar_names + = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name) + $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x)) + names_in_scope + + pp_item x = quotes (ppr x) <+> parens (pprDefinedAt x) + + +--------------- +lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)] +-- GHC extension: look up both the tycon and data con or variable. +-- Used for top-level fixity signatures and deprecations. +-- Complain if neither is in scope. +-- See Note [Fixity signature lookup] +lookupLocalTcNames ctxt what rdr_name + = do { mb_gres <- mapM lookup (dataTcOccs rdr_name) + ; let (errs, names) = partitionEithers mb_gres + ; when (null names) $ addErr (head errs) -- Bleat about one only + ; return names } + where + lookup rdr = do { this_mod <- getModule + ; nameEither <- lookupBindGroupOcc ctxt what rdr + ; return (guard_builtin_syntax this_mod rdr nameEither) } + + -- Guard against the built-in syntax (ex: `infixl 6 :`), see #15233 + guard_builtin_syntax this_mod rdr (Right name) + | Just _ <- isBuiltInOcc_maybe (occName rdr) + , this_mod /= nameModule name + = Left (hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr]) + | otherwise + = Right (rdr, name) + guard_builtin_syntax _ _ (Left err) = Left err + +dataTcOccs :: RdrName -> [RdrName] +-- Return both the given name and the same name promoted to the TcClsName +-- namespace. This is useful when we aren't sure which we are looking at. +-- See also Note [dataTcOccs and Exact Names] +dataTcOccs rdr_name + | isDataOcc occ || isVarOcc occ + = [rdr_name, rdr_name_tc] + | otherwise + = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = + case rdr_name of + -- The (~) type operator is always in scope, so we need a special case + -- for it here, or else :info (~) fails in GHCi. + -- See Note [eqTyCon (~) is built-in syntax] + Unqual occ | occNameFS occ == fsLit "~" -> eqTyCon_RDR + _ -> setRdrNameSpace rdr_name tcName + +{- +Note [dataTcOccs and Exact Names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Exact RdrNames can occur in code generated by Template Haskell, and generally +those references are, well, exact. However, the TH `Name` type isn't expressive +enough to always track the correct namespace information, so we sometimes get +the right Unique but wrong namespace. Thus, we still have to do the double-lookup +for Exact RdrNames. + +There is also an awkward situation for built-in syntax. Example in GHCi + :info [] +This parses as the Exact RdrName for nilDataCon, but we also want +the list type constructor. + +Note that setRdrNameSpace on an Exact name requires the Name to be External, +which it always is for built in syntax. +-} + + + +{- +************************************************************************ +* * + Rebindable names + Dealing with rebindable syntax is driven by the + Opt_RebindableSyntax dynamic flag. + + In "deriving" code we don't want to use rebindable syntax + so we switch off the flag locally + +* * +************************************************************************ + +Haskell 98 says that when you say "3" you get the "fromInteger" from the +Standard Prelude, regardless of what is in scope. However, to experiment +with having a language that is less coupled to the standard prelude, we're +trying a non-standard extension that instead gives you whatever "Prelude.fromInteger" +happens to be in scope. Then you can + import Prelude () + import MyPrelude as Prelude +to get the desired effect. + +At the moment this just happens for + * fromInteger, fromRational on literals (in expressions and patterns) + * negate (in expressions) + * minus (arising from n+k patterns) + * "do" notation + +We store the relevant Name in the HsSyn tree, in + * HsIntegral/HsFractional/HsIsString + * NegApp + * NPlusKPat + * HsDo +respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName, +fromRationalName etc), but the renamer changes this to the appropriate user +name if Opt_NoImplicitPrelude is on. That is what lookupSyntaxName does. + +We treat the original (standard) names as free-vars too, because the type checker +checks the type of the user thing against the type of the standard thing. +-} + +lookupIfThenElse :: RnM (Maybe (SyntaxExpr GhcRn), FreeVars) +-- Different to lookupSyntaxName because in the non-rebindable +-- case we desugar directly rather than calling an existing function +-- Hence the (Maybe (SyntaxExpr GhcRn)) return type +lookupIfThenElse + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if not rebindable_on + then return (Nothing, emptyFVs) + else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse")) + ; return ( Just (mkRnSyntaxExpr ite) + , unitFV ite ) } } + +lookupSyntaxName' :: Name -- ^ The standard name + -> RnM Name -- ^ Possibly a non-standard name +lookupSyntaxName' std_name + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if not rebindable_on then + return std_name + else + -- Get the similarly named thing from the local environment + lookupOccRn (mkRdrUnqual (nameOccName std_name)) } + +lookupSyntaxName :: Name -- The standard name + -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard + -- name +lookupSyntaxName std_name + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if not rebindable_on then + return (mkRnSyntaxExpr std_name, emptyFVs) + else + -- Get the similarly named thing from the local environment + do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name)) + ; return (mkRnSyntaxExpr usr_name, unitFV usr_name) } } + +lookupSyntaxNames :: [Name] -- Standard names + -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames + -- this works with CmdTop, which wants HsExprs, not SyntaxExprs +lookupSyntaxNames std_names + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if not rebindable_on then + return (map (HsVar noExtField . noLoc) std_names, emptyFVs) + else + do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names + ; return (map (HsVar noExtField . noLoc) usr_names, mkFVs usr_names) } } + +-- Error messages + + +opDeclErr :: RdrName -> SDoc +opDeclErr n + = hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n)) + 2 (text "Use TypeOperators to declare operators in type and declarations") + +badOrigBinding :: RdrName -> SDoc +badOrigBinding name + | Just _ <- isBuiltInOcc_maybe occ + = text "Illegal binding of built-in syntax:" <+> ppr occ + -- Use an OccName here because we don't want to print Prelude.(,) + | otherwise + = text "Cannot redefine a Name retrieved by a Template Haskell quote:" + <+> ppr name + -- This can happen when one tries to use a Template Haskell splice to + -- define a top-level identifier with an already existing name, e.g., + -- + -- $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []]) + -- + -- (See #13968.) + where + occ = rdrNameOcc $ filterCTuple name diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs new file mode 100644 index 0000000000..0cae30b1f7 --- /dev/null +++ b/compiler/GHC/Rename/Expr.hs @@ -0,0 +1,2210 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Renaming of expressions + +Basically dependency analysis. + +Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In +general, all of these functions return a renamed thing, and a set of +free variables. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Rename.Expr ( + rnLExpr, rnExpr, rnStmts + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Rename.Binds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS + , rnMatchGroup, rnGRHS, makeMiniFixityEnv) +import GHC.Hs +import TcEnv ( isBrackStage ) +import TcRnMonad +import Module ( getModule ) +import GHC.Rename.Env +import GHC.Rename.Fixity +import GHC.Rename.Utils ( HsDocContext(..), bindLocalNamesFV, checkDupNames + , bindLocalNames + , mapMaybeFvRn, mapFvRn + , warnUnusedLocalBinds, typeAppErr + , checkUnusedRecordWildcard ) +import GHC.Rename.Unbound ( reportUnboundName ) +import GHC.Rename.Splice ( rnBracket, rnSpliceExpr, checkThLocalName ) +import GHC.Rename.Types +import GHC.Rename.Pat +import DynFlags +import PrelNames + +import BasicTypes +import Name +import NameSet +import RdrName +import UniqSet +import Data.List +import Util +import ListSetOps ( removeDups ) +import ErrUtils +import Outputable +import SrcLoc +import FastString +import Control.Monad +import TysWiredIn ( nilDataConName ) +import qualified GHC.LanguageExtensions as LangExt + +import Data.Ord +import Data.Array +import qualified Data.List.NonEmpty as NE + +import Unique ( mkVarOccUnique ) + +{- +************************************************************************ +* * +\subsubsection{Expressions} +* * +************************************************************************ +-} + +rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars) +rnExprs ls = rnExprs' ls emptyUniqSet + where + rnExprs' [] acc = return ([], acc) + rnExprs' (expr:exprs) acc = + do { (expr', fvExpr) <- rnLExpr expr + -- Now we do a "seq" on the free vars because typically it's small + -- or empty, especially in very long lists of constants + ; let acc' = acc `plusFV` fvExpr + ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc' + ; return (expr':exprs', fvExprs) } + +-- Variables. We look up the variable and return the resulting name. + +rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars) +rnLExpr = wrapLocFstM rnExpr + +rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) + +finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars) +-- Separated from rnExpr because it's also used +-- when renaming infix expressions +finishHsVar (L l name) + = do { this_mod <- getModule + ; when (nameIsLocalOrFrom this_mod name) $ + checkThLocalName name + ; return (HsVar noExtField (L l name), unitFV name) } + +rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars) +rnUnboundVar v + = do { if isUnqual v + then -- Treat this as a "hole" + -- Do not fail right now; instead, return HsUnboundVar + -- and let the type checker report the error + return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs) + + else -- Fail immediately (qualified name) + do { n <- reportUnboundName v + ; return (HsVar noExtField (noLoc n), emptyFVs) } } + +rnExpr (HsVar _ (L l v)) + = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields + ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v + ; dflags <- getDynFlags + ; case mb_name of { + Nothing -> rnUnboundVar v ; + Just (Left name) + | name == nilDataConName -- Treat [] as an ExplicitList, so that + -- OverloadedLists works correctly + -- Note [Empty lists] in GHC.Hs.Expr + , xopt LangExt.OverloadedLists dflags + -> rnExpr (ExplicitList noExtField Nothing []) + + | otherwise + -> finishHsVar (L l name) ; + Just (Right [s]) -> + return ( HsRecFld noExtField (Unambiguous s (L l v) ), unitFV s) ; + Just (Right fs@(_:_:_)) -> + return ( HsRecFld noExtField (Ambiguous noExtField (L l v)) + , mkFVs fs); + Just (Right []) -> panic "runExpr/HsVar" } } + +rnExpr (HsIPVar x v) + = return (HsIPVar x v, emptyFVs) + +rnExpr (HsUnboundVar x v) + = return (HsUnboundVar x v, emptyFVs) + +rnExpr (HsOverLabel x _ v) + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if rebindable_on + then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel")) + ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) } + else return (HsOverLabel x Nothing v, emptyFVs) } + +rnExpr (HsLit x lit@(HsString src s)) + = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings + ; if opt_OverloadedStrings then + rnExpr (HsOverLit x (mkHsIsString src s)) + else do { + ; rnLit lit + ; return (HsLit x (convertLit lit), emptyFVs) } } + +rnExpr (HsLit x lit) + = do { rnLit lit + ; return (HsLit x(convertLit lit), emptyFVs) } + +rnExpr (HsOverLit x lit) + = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero] + ; case mb_neg of + Nothing -> return (HsOverLit x lit', fvs) + Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit')) + , fvs ) } + +rnExpr (HsApp x fun arg) + = do { (fun',fvFun) <- rnLExpr fun + ; (arg',fvArg) <- rnLExpr arg + ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) } + +rnExpr (HsAppType x fun arg) + = do { type_app <- xoptM LangExt.TypeApplications + ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg + ; (fun',fvFun) <- rnLExpr fun + ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg + ; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) } + +rnExpr (OpApp _ e1 op e2) + = do { (e1', fv_e1) <- rnLExpr e1 + ; (e2', fv_e2) <- rnLExpr e2 + ; (op', fv_op) <- rnLExpr op + + -- Deal with fixity + -- When renaming code synthesised from "deriving" declarations + -- we used to avoid fixity stuff, but we can't easily tell any + -- more, so I've removed the test. Adding HsPars in TcGenDeriv + -- should prevent bad things happening. + ; fixity <- case op' of + L _ (HsVar _ (L _ n)) -> lookupFixityRn n + L _ (HsRecFld _ f) -> lookupFieldFixityRn f + _ -> return (Fixity NoSourceText minPrecedence InfixL) + -- c.f. lookupFixity for unbound + + ; final_e <- mkOpAppRn e1' op' fixity e2' + ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) } + +rnExpr (NegApp _ e _) + = do { (e', fv_e) <- rnLExpr e + ; (neg_name, fv_neg) <- lookupSyntaxName negateName + ; final_e <- mkNegAppRn e' neg_name + ; return (final_e, fv_e `plusFV` fv_neg) } + +------------------------------------------ +-- Template Haskell extensions +rnExpr e@(HsBracket _ br_body) = rnBracket e br_body + +rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice + +--------------------------------------------- +-- Sections +-- See Note [Parsing sections] in Parser.y +rnExpr (HsPar x (L loc (section@(SectionL {})))) + = do { (section', fvs) <- rnSection section + ; return (HsPar x (L loc section'), fvs) } + +rnExpr (HsPar x (L loc (section@(SectionR {})))) + = do { (section', fvs) <- rnSection section + ; return (HsPar x (L loc section'), fvs) } + +rnExpr (HsPar x e) + = do { (e', fvs_e) <- rnLExpr e + ; return (HsPar x e', fvs_e) } + +rnExpr expr@(SectionL {}) + = do { addErr (sectionErr expr); rnSection expr } +rnExpr expr@(SectionR {}) + = do { addErr (sectionErr expr); rnSection expr } + +--------------------------------------------- +rnExpr (HsPragE x prag expr) + = do { (expr', fvs_expr) <- rnLExpr expr + ; return (HsPragE x (rn_prag prag) expr', fvs_expr) } + where + rn_prag :: HsPragE GhcPs -> HsPragE GhcRn + rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann + rn_prag (HsPragCore x1 src lbl) = HsPragCore x1 src lbl + rn_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo + rn_prag (XHsPragE x) = noExtCon x + +rnExpr (HsLam x matches) + = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches + ; return (HsLam x matches', fvMatch) } + +rnExpr (HsLamCase x matches) + = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches + ; return (HsLamCase x matches', fvs_ms) } + +rnExpr (HsCase x expr matches) + = do { (new_expr, e_fvs) <- rnLExpr expr + ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches + ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } + +rnExpr (HsLet x (L l binds) expr) + = rnLocalBindsAndThen binds $ \binds' _ -> do + { (expr',fvExpr) <- rnLExpr expr + ; return (HsLet x (L l binds') expr', fvExpr) } + +rnExpr (HsDo x do_or_lc (L l stmts)) + = do { ((stmts', _), fvs) <- + rnStmtsWithPostProcessing do_or_lc rnLExpr + postProcessStmtsForApplicativeDo stmts + (\ _ -> return ((), emptyFVs)) + ; return ( HsDo x do_or_lc (L l stmts'), fvs ) } + +rnExpr (ExplicitList x _ exps) + = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists + ; (exps', fvs) <- rnExprs exps + ; if opt_OverloadedLists + then do { + ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName + ; return (ExplicitList x (Just from_list_n_name) exps' + , fvs `plusFV` fvs') } + else + return (ExplicitList x Nothing exps', fvs) } + +rnExpr (ExplicitTuple x tup_args boxity) + = do { checkTupleSection tup_args + ; checkTupSize (length tup_args) + ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args + ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) } + where + rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e + ; return (L l (Present x e'), fvs) } + rnTupArg (L l (Missing _)) = return (L l (Missing noExtField) + , emptyFVs) + rnTupArg (L _ (XTupArg nec)) = noExtCon nec + +rnExpr (ExplicitSum x alt arity expr) + = do { (expr', fvs) <- rnLExpr expr + ; return (ExplicitSum x alt arity expr', fvs) } + +rnExpr (RecordCon { rcon_con_name = con_id + , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) }) + = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id + ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds + ; (flds', fvss) <- mapAndUnzipM rn_field flds + ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd } + ; return (RecordCon { rcon_ext = noExtField + , rcon_con_name = con_lname, rcon_flds = rec_binds' } + , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } + where + mk_hs_var l n = HsVar noExtField (L l n) + rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) + ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } + +rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) + = do { (expr', fvExpr) <- rnLExpr expr + ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds + ; return (RecordUpd { rupd_ext = noExtField, rupd_expr = expr' + , rupd_flds = rbinds' } + , fvExpr `plusFV` fvRbinds) } + +rnExpr (ExprWithTySig _ expr pty) + = do { (pty', fvTy) <- rnHsSigWcType BindUnlessForall ExprWithTySigCtx pty + ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ + rnLExpr expr + ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) } + +rnExpr (HsIf x _ p b1 b2) + = do { (p', fvP) <- rnLExpr p + ; (b1', fvB1) <- rnLExpr b1 + ; (b2', fvB2) <- rnLExpr b2 + ; (mb_ite, fvITE) <- lookupIfThenElse + ; return (HsIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } + +rnExpr (HsMultiIf x alts) + = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts + -- ; return (HsMultiIf ty alts', fvs) } + ; return (HsMultiIf x alts', fvs) } + +rnExpr (ArithSeq x _ seq) + = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists + ; (new_seq, fvs) <- rnArithSeq seq + ; if opt_OverloadedLists + then do { + ; (from_list_name, fvs') <- lookupSyntaxName fromListName + ; return (ArithSeq x (Just from_list_name) new_seq + , fvs `plusFV` fvs') } + else + return (ArithSeq x Nothing new_seq, fvs) } + +{- +************************************************************************ +* * + Static values +* * +************************************************************************ + +For the static form we check that it is not used in splices. +We also collect the free variables of the term which come from +this module. See Note [Grand plan for static forms] in StaticPtrTable. +-} + +rnExpr e@(HsStatic _ expr) = do + -- Normally, you wouldn't be able to construct a static expression without + -- first enabling -XStaticPointers in the first place, since that extension + -- is what makes the parser treat `static` as a keyword. But this is not a + -- sufficient safeguard, as one can construct static expressions by another + -- mechanism: Template Haskell (see #14204). To ensure that GHC is + -- absolutely prepared to cope with static forms, we check for + -- -XStaticPointers here as well. + unlessXOptM LangExt.StaticPointers $ + addErr $ hang (text "Illegal static expression:" <+> ppr e) + 2 (text "Use StaticPointers to enable this extension") + (expr',fvExpr) <- rnLExpr expr + stage <- getStage + case stage of + Splice _ -> addErr $ sep + [ text "static forms cannot be used in splices:" + , nest 2 $ ppr e + ] + _ -> return () + mod <- getModule + let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr + return (HsStatic fvExpr' expr', fvExpr) + +{- +************************************************************************ +* * + Arrow notation +* * +************************************************************************ +-} + +rnExpr (HsProc x pat body) + = newArrowScope $ + rnPat ProcExpr pat $ \ pat' -> do + { (body',fvBody) <- rnCmdTop body + ; return (HsProc x pat' body', fvBody) } + +rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) + -- HsWrap + +---------------------- +-- See Note [Parsing sections] in Parser.y +rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) +rnSection section@(SectionR x op expr) + = do { (op', fvs_op) <- rnLExpr op + ; (expr', fvs_expr) <- rnLExpr expr + ; checkSectionPrec InfixR section op' expr' + ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) } + +rnSection section@(SectionL x expr op) + = do { (expr', fvs_expr) <- rnLExpr expr + ; (op', fvs_op) <- rnLExpr op + ; checkSectionPrec InfixL section op' expr' + ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) } + +rnSection other = pprPanic "rnSection" (ppr other) + +{- +************************************************************************ +* * + Arrow commands +* * +************************************************************************ +-} + +rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars) +rnCmdArgs [] = return ([], emptyFVs) +rnCmdArgs (arg:args) + = do { (arg',fvArg) <- rnCmdTop arg + ; (args',fvArgs) <- rnCmdArgs args + ; return (arg':args', fvArg `plusFV` fvArgs) } + +rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars) +rnCmdTop = wrapLocFstM rnCmdTop' + where + rnCmdTop' (HsCmdTop _ cmd) + = do { (cmd', fvCmd) <- rnLCmd cmd + ; let cmd_names = [arrAName, composeAName, firstAName] ++ + nameSetElemsStable (methodNamesCmd (unLoc cmd')) + -- Generate the rebindable syntax for the monad + ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names + + ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd', + fvCmd `plusFV` cmd_fvs) } + rnCmdTop' (XCmdTop nec) = noExtCon nec + +rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars) +rnLCmd = wrapLocFstM rnCmd + +rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars) + +rnCmd (HsCmdArrApp x arrow arg ho rtl) + = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) + ; (arg',fvArg) <- rnLExpr arg + ; return (HsCmdArrApp x arrow' arg' ho rtl, + fvArrow `plusFV` fvArg) } + where + select_arrow_scope tc = case ho of + HsHigherOrderApp -> tc + HsFirstOrderApp -> escapeArrowScope tc + -- See Note [Escaping the arrow scope] in TcRnTypes + -- Before renaming 'arrow', use the environment of the enclosing + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope + -- inside 'arrow'. In the higher-order case (-<<), they are. + +-- infix form +rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2]) + = do { (op',fv_op) <- escapeArrowScope (rnLExpr op) + ; let L _ (HsVar _ (L _ op_name)) = op' + ; (arg1',fv_arg1) <- rnCmdTop arg1 + ; (arg2',fv_arg2) <- rnCmdTop arg2 + -- Deal with fixity + ; fixity <- lookupFixityRn op_name + ; final_e <- mkOpFormRn arg1' op' fixity arg2' + ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) } + +rnCmd (HsCmdArrForm x op f fixity cmds) + = do { (op',fvOp) <- escapeArrowScope (rnLExpr op) + ; (cmds',fvCmds) <- rnCmdArgs cmds + ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) } + +rnCmd (HsCmdApp x fun arg) + = do { (fun',fvFun) <- rnLCmd fun + ; (arg',fvArg) <- rnLExpr arg + ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) } + +rnCmd (HsCmdLam x matches) + = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches + ; return (HsCmdLam x matches', fvMatch) } + +rnCmd (HsCmdPar x e) + = do { (e', fvs_e) <- rnLCmd e + ; return (HsCmdPar x e', fvs_e) } + +rnCmd (HsCmdCase x expr matches) + = do { (new_expr, e_fvs) <- rnLExpr expr + ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches + ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) } + +rnCmd (HsCmdIf x _ p b1 b2) + = do { (p', fvP) <- rnLExpr p + ; (b1', fvB1) <- rnLCmd b1 + ; (b2', fvB2) <- rnLCmd b2 + ; (mb_ite, fvITE) <- lookupIfThenElse + ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} + +rnCmd (HsCmdLet x (L l binds) cmd) + = rnLocalBindsAndThen binds $ \ binds' _ -> do + { (cmd',fvExpr) <- rnLCmd cmd + ; return (HsCmdLet x (L l binds') cmd', fvExpr) } + +rnCmd (HsCmdDo x (L l stmts)) + = do { ((stmts', _), fvs) <- + rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs)) + ; return ( HsCmdDo x (L l stmts'), fvs ) } + +rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd) +rnCmd (XCmd nec) = noExtCon nec + +--------------------------------------------------- +type CmdNeeds = FreeVars -- Only inhabitants are + -- appAName, choiceAName, loopAName + +-- find what methods the Cmd needs (loop, choice, apply) +methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds +methodNamesLCmd = methodNamesCmd . unLoc + +methodNamesCmd :: HsCmd GhcRn -> CmdNeeds + +methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl) + = emptyFVs +methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl) + = unitFV appAName +methodNamesCmd (HsCmdArrForm {}) = emptyFVs +methodNamesCmd (HsCmdWrap _ _ cmd) = methodNamesCmd cmd + +methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c + +methodNamesCmd (HsCmdIf _ _ _ c1 c2) + = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName + +methodNamesCmd (HsCmdLet _ _ c) = methodNamesLCmd c +methodNamesCmd (HsCmdDo _ (L _ stmts)) = methodNamesStmts stmts +methodNamesCmd (HsCmdApp _ c _) = methodNamesLCmd c +methodNamesCmd (HsCmdLam _ match) = methodNamesMatch match + +methodNamesCmd (HsCmdCase _ _ matches) + = methodNamesMatch matches `addOneFV` choiceAName + +methodNamesCmd (XCmd nec) = noExtCon nec + +--methodNamesCmd _ = emptyFVs + -- Other forms can't occur in commands, but it's not convenient + -- to error here so we just do what's convenient. + -- The type checker will complain later + +--------------------------------------------------- +methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars +methodNamesMatch (MG { mg_alts = L _ ms }) + = plusFVs (map do_one ms) + where + do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss + do_one (L _ (XMatch nec)) = noExtCon nec +methodNamesMatch (XMatchGroup nec) = noExtCon nec + +------------------------------------------------- +-- gaw 2004 +methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars +methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss) +methodNamesGRHSs (XGRHSs nec) = noExtCon nec + +------------------------------------------------- + +methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds +methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs +methodNamesGRHS (L _ (XGRHS nec)) = noExtCon nec + +--------------------------------------------------- +methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars +methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts) + +--------------------------------------------------- +methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars +methodNamesLStmt = methodNamesStmt . unLoc + +methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars +methodNamesStmt (LastStmt _ cmd _ _) = methodNamesLCmd cmd +methodNamesStmt (BodyStmt _ cmd _ _) = methodNamesLCmd cmd +methodNamesStmt (BindStmt _ _ cmd _ _) = methodNamesLCmd cmd +methodNamesStmt (RecStmt { recS_stmts = stmts }) = + methodNamesStmts stmts `addOneFV` loopAName +methodNamesStmt (LetStmt {}) = emptyFVs +methodNamesStmt (ParStmt {}) = emptyFVs +methodNamesStmt (TransStmt {}) = emptyFVs +methodNamesStmt ApplicativeStmt{} = emptyFVs + -- ParStmt and TransStmt can't occur in commands, but it's not + -- convenient to error here so we just do what's convenient +methodNamesStmt (XStmtLR nec) = noExtCon nec + +{- +************************************************************************ +* * + Arithmetic sequences +* * +************************************************************************ +-} + +rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars) +rnArithSeq (From expr) + = do { (expr', fvExpr) <- rnLExpr expr + ; return (From expr', fvExpr) } + +rnArithSeq (FromThen expr1 expr2) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) } + +rnArithSeq (FromTo expr1 expr2) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) } + +rnArithSeq (FromThenTo expr1 expr2 expr3) + = do { (expr1', fvExpr1) <- rnLExpr expr1 + ; (expr2', fvExpr2) <- rnLExpr expr2 + ; (expr3', fvExpr3) <- rnLExpr expr3 + ; return (FromThenTo expr1' expr2' expr3', + plusFVs [fvExpr1, fvExpr2, fvExpr3]) } + +{- +************************************************************************ +* * +\subsubsection{@Stmt@s: in @do@ expressions} +* * +************************************************************************ +-} + +{- +Note [Deterministic ApplicativeDo and RecursiveDo desugaring] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Both ApplicativeDo and RecursiveDo need to create tuples not +present in the source text. + +For ApplicativeDo we create: + + (a,b,c) <- (\c b a -> (a,b,c)) <$> + +For RecursiveDo we create: + + mfix (\ ~(a,b,c) -> do ...; return (a',b',c')) + +The order of the components in those tuples needs to be stable +across recompilations, otherwise they can get optimized differently +and we end up with incompatible binaries. +To get a stable order we use nameSetElemsStable. +See Note [Deterministic UniqFM] to learn more about nondeterminism. +-} + +-- | Rename some Stmts +rnStmts :: Outputable (body GhcPs) + => HsStmtContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -- ^ How to rename the body of each statement (e.g. rnLExpr) + -> [LStmt GhcPs (Located (body GhcPs))] + -- ^ Statements + -> ([Name] -> RnM (thing, FreeVars)) + -- ^ if these statements scope over something, this renames it + -- and returns the result. + -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) +rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts + +-- | like 'rnStmts' but applies a post-processing step to the renamed Stmts +rnStmtsWithPostProcessing + :: Outputable (body GhcPs) + => HsStmtContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -- ^ How to rename the body of each statement (e.g. rnLExpr) + -> (HsStmtContext Name + -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] + -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)) + -- ^ postprocess the statements + -> [LStmt GhcPs (Located (body GhcPs))] + -- ^ Statements + -> ([Name] -> RnM (thing, FreeVars)) + -- ^ if these statements scope over something, this renames it + -- and returns the result. + -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) +rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside + = do { ((stmts', thing), fvs) <- + rnStmtsWithFreeVars ctxt rnBody stmts thing_inside + ; (pp_stmts, fvs') <- ppStmts ctxt stmts' + ; return ((pp_stmts, thing), fvs `plusFV` fvs') + } + +-- | maybe rearrange statements according to the ApplicativeDo transformation +postProcessStmtsForApplicativeDo + :: HsStmtContext Name + -> [(ExprLStmt GhcRn, FreeVars)] + -> RnM ([ExprLStmt GhcRn], FreeVars) +postProcessStmtsForApplicativeDo ctxt stmts + = do { + -- rearrange the statements using ApplicativeStmt if + -- -XApplicativeDo is on. Also strip out the FreeVars attached + -- to each Stmt body. + ado_is_on <- xoptM LangExt.ApplicativeDo + ; let is_do_expr | DoExpr <- ctxt = True + | otherwise = False + -- don't apply the transformation inside TH brackets, because + -- DsMeta does not handle ApplicativeDo. + ; in_th_bracket <- isBrackStage <$> getStage + ; if ado_is_on && is_do_expr && not in_th_bracket + then do { traceRn "ppsfa" (ppr stmts) + ; rearrangeForApplicativeDo ctxt stmts } + else noPostProcessStmts ctxt stmts } + +-- | strip the FreeVars annotations from statements +noPostProcessStmts + :: HsStmtContext Name + -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] + -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars) +noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet) + + +rnStmtsWithFreeVars :: Outputable (body GhcPs) + => HsStmtContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> [LStmt GhcPs (Located (body GhcPs))] + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) + , FreeVars) +-- Each Stmt body is annotated with its FreeVars, so that +-- we can rearrange statements for ApplicativeDo. +-- +-- Variables bound by the Stmts, and mentioned in thing_inside, +-- do not appear in the result FreeVars + +rnStmtsWithFreeVars ctxt _ [] thing_inside + = do { checkEmptyStmts ctxt + ; (thing, fvs) <- thing_inside [] + ; return (([], thing), fvs) } + +rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside -- Deal with mdo + = -- Behave like do { rec { ...all but last... }; last } + do { ((stmts1, (stmts2, thing)), fvs) + <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ -> + do { last_stmt' <- checkLastStmt MDoExpr last_stmt + ; rnStmt MDoExpr rnBody last_stmt' thing_inside } + ; return (((stmts1 ++ stmts2), thing), fvs) } + where + Just (all_but_last, last_stmt) = snocView stmts + +rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside + | null lstmts + = setSrcSpan loc $ + do { lstmt' <- checkLastStmt ctxt lstmt + ; rnStmt ctxt rnBody lstmt' thing_inside } + + | otherwise + = do { ((stmts1, (stmts2, thing)), fvs) + <- setSrcSpan loc $ + do { checkStmt ctxt lstmt + ; rnStmt ctxt rnBody lstmt $ \ bndrs1 -> + rnStmtsWithFreeVars ctxt rnBody lstmts $ \ bndrs2 -> + thing_inside (bndrs1 ++ bndrs2) } + ; return (((stmts1 ++ stmts2), thing), fvs) } + +---------------------- + +{- +Note [Failing pattern matches in Stmts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Many things desugar to HsStmts including monadic things like `do` and `mdo` +statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an +exhaustive list). How we deal with pattern match failure is context-dependent. + + * In the case of list comprehensions and pattern guards we don't need any 'fail' + function; the desugarer ignores the fail function field of 'BindStmt' entirely. + * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo + expressions) we want pattern match failure to be desugared to the appropriate + 'fail' function (either that of Monad or MonadFail, depending on whether + -XMonadFailDesugaring is enabled.) + +At one point we failed to make this distinction, leading to #11216. +-} + +rnStmt :: Outputable (body GhcPs) + => HsStmtContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -- ^ How to rename the body of the statement + -> LStmt GhcPs (Located (body GhcPs)) + -- ^ The statement + -> ([Name] -> RnM (thing, FreeVars)) + -- ^ Rename the stuff that this statement scopes over + -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) + , FreeVars) +-- Variables bound by the Stmt, and mentioned in thing_inside, +-- do not appear in the result FreeVars + +rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside + = do { (body', fv_expr) <- rnBody body + ; (ret_op, fvs1) <- if isMonadCompContext ctxt + then lookupStmtName ctxt returnMName + else return (noSyntaxExpr, emptyFVs) + -- The 'return' in a LastStmt is used only + -- for MonadComp; and we don't want to report + -- "non in scope: return" in other cases + -- #15607 + + ; (thing, fvs3) <- thing_inside [] + ; return (([(L loc (LastStmt noExtField body' noret ret_op), fv_expr)] + , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) } + +rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside + = do { (body', fv_expr) <- rnBody body + ; (then_op, fvs1) <- lookupStmtName ctxt thenMName + + ; (guard_op, fvs2) <- if isComprehensionContext ctxt + then lookupStmtName ctxt guardMName + else return (noSyntaxExpr, emptyFVs) + -- Only list/monad comprehensions use 'guard' + -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] + -- Here "gd" is a guard + + ; (thing, fvs3) <- thing_inside [] + ; return ( ([(L loc (BodyStmt noExtField body' then_op guard_op), fv_expr)] + , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } + +rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside + = do { (body', fv_expr) <- rnBody body + -- The binders do not scope over the expression + ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName + + ; (fail_op, fvs2) <- monadFailOp pat ctxt + + ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do + { (thing, fvs3) <- thing_inside (collectPatBinders pat') + ; return (( [( L loc (BindStmt noExtField pat' body' bind_op fail_op) + , fv_expr )] + , thing), + fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} + -- fv_expr shouldn't really be filtered by the rnPatsAndThen + -- but it does not matter because the names are unique + +rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside + = do { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do + { (thing, fvs) <- thing_inside (collectLocalBinders binds') + ; return ( ([(L loc (LetStmt noExtField (L l binds')), bind_fvs)], thing) + , fvs) } } + +rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside + = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName + ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName + ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName + ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn = return_op + , recS_mfix_fn = mfix_op + , recS_bind_fn = bind_op } + + -- Step1: Bring all the binders of the mdo into scope + -- (Remember that this also removes the binders from the + -- finally-returned free-vars.) + -- And rename each individual stmt, making a + -- singleton segment. At this stage the FwdRefs field + -- isn't finished: it's empty for all except a BindStmt + -- for which it's the fwd refs within the bind itself + -- (This set may not be empty, because we're in a recursive + -- context.) + ; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do + { let bndrs = nameSetElemsStable $ + foldr (unionNameSet . (\(ds,_,_,_) -> ds)) + emptyNameSet + segs + -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] + ; (thing, fvs_later) <- thing_inside bndrs + ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later + -- We aren't going to try to group RecStmts with + -- ApplicativeDo, so attaching empty FVs is fine. + ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing) + , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } + +rnStmt ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside + = do { (mzip_op, fvs1) <- lookupStmtNamePoly ctxt mzipName + ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName + ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside + ; return (([(L loc (ParStmt noExtField segs' mzip_op bind_op), fvs4)], thing) + , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } + +rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form + , trS_using = using })) thing_inside + = do { -- Rename the 'using' expression in the context before the transform is begun + (using', fvs1) <- rnLExpr using + + -- Rename the stmts and the 'by' expression + -- Keep track of the variables mentioned in the 'by' expression + ; ((stmts', (by', used_bndrs, thing)), fvs2) + <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs -> + do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by + ; (thing, fvs_thing) <- thing_inside bndrs + ; let fvs = fvs_by `plusFV` fvs_thing + used_bndrs = filter (`elemNameSet` fvs) bndrs + -- The paper (Fig 5) has a bug here; we must treat any free variable + -- of the "thing inside", **or of the by-expression**, as used + ; return ((by', used_bndrs, thing), fvs) } + + -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName + ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName + ; (fmap_op, fvs5) <- case form of + ThenForm -> return (noExpr, emptyFVs) + _ -> lookupStmtNamePoly ctxt fmapName + + ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 + `plusFV` fvs4 `plusFV` fvs5 + bndr_map = used_bndrs `zip` used_bndrs + -- See Note [TransStmt binder map] in GHC.Hs.Expr + + ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map) + ; return (([(L loc (TransStmt { trS_ext = noExtField + , trS_stmts = stmts', trS_bndrs = bndr_map + , trS_by = by', trS_using = using', trS_form = form + , trS_ret = return_op, trS_bind = bind_op + , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) } + +rnStmt _ _ (L _ ApplicativeStmt{}) _ = + panic "rnStmt: ApplicativeStmt" + +rnStmt _ _ (L _ (XStmtLR nec)) _ = + noExtCon nec + +rnParallelStmts :: forall thing. HsStmtContext Name + -> SyntaxExpr GhcRn + -> [ParStmtBlock GhcPs GhcPs] + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars) +-- Note [Renaming parallel Stmts] +rnParallelStmts ctxt return_op segs thing_inside + = do { orig_lcl_env <- getLocalRdrEnv + ; rn_segs orig_lcl_env [] segs } + where + rn_segs :: LocalRdrEnv + -> [Name] -> [ParStmtBlock GhcPs GhcPs] + -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars) + rn_segs _ bndrs_so_far [] + = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far + ; mapM_ dupErr dups + ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs') + ; return (([], thing), fvs) } + + rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs) + = do { ((stmts', (used_bndrs, segs', thing)), fvs) + <- rnStmts ctxt rnLExpr stmts $ \ bndrs -> + setLocalRdrEnv env $ do + { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs + ; let used_bndrs = filter (`elemNameSet` fvs) bndrs + ; return ((used_bndrs, segs', thing), fvs) } + + ; let seg' = ParStmtBlock x stmts' used_bndrs return_op + ; return ((seg':segs', thing), fvs) } + rn_segs _ _ (XParStmtBlock nec:_) = noExtCon nec + + cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 + dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" + <+> quotes (ppr (NE.head vs))) + +lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) +-- Like lookupSyntaxName, but respects contexts +lookupStmtName ctxt n + | rebindableContext ctxt + = lookupSyntaxName n + | otherwise + = return (mkRnSyntaxExpr n, emptyFVs) + +lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars) +lookupStmtNamePoly ctxt name + | rebindableContext ctxt + = do { rebindable_on <- xoptM LangExt.RebindableSyntax + ; if rebindable_on + then do { fm <- lookupOccRn (nameRdrName name) + ; return (HsVar noExtField (noLoc fm), unitFV fm) } + else not_rebindable } + | otherwise + = not_rebindable + where + not_rebindable = return (HsVar noExtField (noLoc name), emptyFVs) + +-- | Is this a context where we respect RebindableSyntax? +-- but ListComp are never rebindable +-- Neither is ArrowExpr, which has its own desugarer in DsArrows +rebindableContext :: HsStmtContext Name -> Bool +rebindableContext ctxt = case ctxt of + ListComp -> False + ArrowExpr -> False + PatGuard {} -> False + + DoExpr -> True + MDoExpr -> True + MonadComp -> True + GhciStmtCtxt -> True -- I suppose? + + ParStmtCtxt c -> rebindableContext c -- Look inside to + TransStmtCtxt c -> rebindableContext c -- the parent context + +{- +Note [Renaming parallel Stmts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Renaming parallel statements is painful. Given, say + [ a+c | a <- as, bs <- bss + | c <- bs, a <- ds ] +Note that + (a) In order to report "Defined but not used" about 'bs', we must + rename each group of Stmts with a thing_inside whose FreeVars + include at least {a,c} + + (b) We want to report that 'a' is illegally bound in both branches + + (c) The 'bs' in the second group must obviously not be captured by + the binding in the first group + +To satisfy (a) we nest the segements. +To satisfy (b) we check for duplicates just before thing_inside. +To satisfy (c) we reset the LocalRdrEnv each time. + +************************************************************************ +* * +\subsubsection{mdo expressions} +* * +************************************************************************ +-} + +type FwdRefs = NameSet +type Segment stmts = (Defs, + Uses, -- May include defs + FwdRefs, -- A subset of uses that are + -- (a) used before they are bound in this segment, or + -- (b) used here, and bound in subsequent segments + stmts) -- Either Stmt or [Stmt] + + +-- wrapper that does both the left- and right-hand sides +rnRecStmtsAndThen :: Outputable (body GhcPs) => + (Located (body GhcPs) + -> RnM (Located (body GhcRn), FreeVars)) + -> [LStmt GhcPs (Located (body GhcPs))] + -- assumes that the FreeVars returned includes + -- the FreeVars of the Segments + -> ([Segment (LStmt GhcRn (Located (body GhcRn)))] + -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnRecStmtsAndThen rnBody s cont + = do { -- (A) Make the mini fixity env for all of the stmts + fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) + + -- (B) Do the LHSes + ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s + + -- ...bring them and their fixities into scope + ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv) + -- Fake uses of variables introduced implicitly (warning suppression, see #4404) + rec_uses = lStmtsImplicits (map fst new_lhs_and_fv) + implicit_uses = mkNameSet $ concatMap snd $ rec_uses + ; bindLocalNamesFV bound_names $ + addLocalFixities fix_env bound_names $ do + + -- (C) do the right-hand-sides and thing-inside + { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv + ; (res, fvs) <- cont segs + ; mapM_ (\(loc, ns) -> checkUnusedRecordWildcard loc fvs (Just ns)) + rec_uses + ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses) + ; return (res, fvs) }} + +-- get all the fixity decls in any Let stmt +collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] +collectRecStmtsFixities l = + foldr (\ s -> \acc -> case s of + (L _ (LetStmt _ (L _ (HsValBinds _ (ValBinds _ _ sigs))))) -> + foldr (\ sig -> \ acc -> case sig of + (L loc (FixSig _ s)) -> (L loc s) : acc + _ -> acc) acc sigs + _ -> acc) [] l + +-- left-hand sides + +rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv + -> LStmt GhcPs body + -- rename LHS, and return its FVs + -- Warning: we will only need the FreeVars below in the case of a BindStmt, + -- so we don't bother to compute it accurately in the other cases + -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] + +rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b)) + = return [(L loc (BodyStmt noExtField body a b), emptyFVs)] + +rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a)) + = return [(L loc (LastStmt noExtField body noret a), emptyFVs)] + +rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b)) + = do + -- should the ctxt be MDo instead? + (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat + return [(L loc (BindStmt noExtField pat' body a b), fv_pat)] + +rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {})))) + = failWith (badIpBinds (text "an mdo expression") binds) + +rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds)))) + = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds + return [(L loc (LetStmt noExtField (L l (HsValBinds x binds'))), + -- Warning: this is bogus; see function invariant + emptyFVs + )] + +-- XXX Do we need to do something with the return and mfix names? +rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec + = rn_rec_stmts_lhs fix_env stmts + +rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt" (ppr stmt) + +rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt" (ppr stmt) + +rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet + = pprPanic "rn_rec_stmt" (ppr stmt) + +rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _)))) + = panic "rn_rec_stmt LetStmt EmptyLocalBinds" +rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec)))) + = noExtCon nec +rn_rec_stmt_lhs _ (L _ (XStmtLR nec)) + = noExtCon nec + +rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv + -> [LStmt GhcPs body] + -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] +rn_rec_stmts_lhs fix_env stmts + = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts + ; let boundNames = collectLStmtsBinders (map fst ls) + -- First do error checking: we need to check for dups here because we + -- don't bind all of the variables from the Stmt at once + -- with bindLocatedLocals. + ; checkDupNames boundNames + ; return ls } + + +-- right-hand-sides + +rn_rec_stmt :: (Outputable (body GhcPs)) => + (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> [Name] + -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars) + -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] + -- Rename a Stmt that is inside a RecStmt (or mdo) + -- Assumes all binders are already in scope + -- Turns each stmt into a singleton Stmt +rn_rec_stmt rnBody _ (L loc (LastStmt _ body noret _), _) + = do { (body', fv_expr) <- rnBody body + ; (ret_op, fvs1) <- lookupSyntaxName returnMName + ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, + L loc (LastStmt noExtField body' noret ret_op))] } + +rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _) + = do { (body', fvs) <- rnBody body + ; (then_op, fvs1) <- lookupSyntaxName thenMName + ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, + L loc (BodyStmt noExtField body' then_op noSyntaxExpr))] } + +rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat) + = do { (body', fv_expr) <- rnBody body + ; (bind_op, fvs1) <- lookupSyntaxName bindMName + + ; (fail_op, fvs2) <- getMonadFailOp + + ; let bndrs = mkNameSet (collectPatBinders pat') + fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 + ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs, + L loc (BindStmt noExtField pat' body' bind_op fail_op))] } + +rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _) + = failWith (badIpBinds (text "an mdo expression") binds) + +rn_rec_stmt _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _) + = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds' + -- fixities and unused are handled above in rnRecStmtsAndThen + ; let fvs = allUses du_binds + ; return [(duDefs du_binds, fvs, emptyNameSet, + L loc (LetStmt noExtField (L l (HsValBinds x binds'))))] } + +-- no RecStmt case because they get flattened above when doing the LHSes +rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _) + = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt) + +rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt) + +rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) + +rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR nec))), _) + = noExtCon nec + +rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _) + = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" + +rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _) + = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) + +rn_rec_stmt _ _ (L _ (XStmtLR nec), _) + = noExtCon nec + +rn_rec_stmts :: Outputable (body GhcPs) => + (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> [Name] + -> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)] + -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] +rn_rec_stmts rnBody bndrs stmts + = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts + ; return (concat segs_s) } + +--------------------------------------------- +segmentRecStmts :: SrcSpan -> HsStmtContext Name + -> Stmt GhcRn body + -> [Segment (LStmt GhcRn body)] -> FreeVars + -> ([LStmt GhcRn body], FreeVars) + +segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later + | null segs + = ([], fvs_later) + + | MDoExpr <- ctxt + = segsToStmts empty_rec_stmt grouped_segs fvs_later + -- Step 4: Turn the segments into Stmts + -- Use RecStmt when and only when there are fwd refs + -- Also gather up the uses from the end towards the + -- start, so we can tell the RecStmt which things are + -- used 'after' the RecStmt + + | otherwise + = ([ L loc $ + empty_rec_stmt { recS_stmts = ss + , recS_later_ids = nameSetElemsStable + (defs `intersectNameSet` fvs_later) + , recS_rec_ids = nameSetElemsStable + (defs `intersectNameSet` uses) }] + -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] + , uses `plusFV` fvs_later) + + where + (defs_s, uses_s, _, ss) = unzip4 segs + defs = plusFVs defs_s + uses = plusFVs uses_s + + -- Step 2: Fill in the fwd refs. + -- The segments are all singletons, but their fwd-ref + -- field mentions all the things used by the segment + -- that are bound after their use + segs_w_fwd_refs = addFwdRefs segs + + -- Step 3: Group together the segments to make bigger segments + -- Invariant: in the result, no segment uses a variable + -- bound in a later segment + grouped_segs = glomSegments ctxt segs_w_fwd_refs + +---------------------------- +addFwdRefs :: [Segment a] -> [Segment a] +-- So far the segments only have forward refs *within* the Stmt +-- (which happens for bind: x <- ...x...) +-- This function adds the cross-seg fwd ref info + +addFwdRefs segs + = fst (foldr mk_seg ([], emptyNameSet) segs) + where + mk_seg (defs, uses, fwds, stmts) (segs, later_defs) + = (new_seg : segs, all_defs) + where + new_seg = (defs, uses, new_fwds, stmts) + all_defs = later_defs `unionNameSet` defs + new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs) + -- Add the downstream fwd refs here + +{- +Note [Segmenting mdo] +~~~~~~~~~~~~~~~~~~~~~ +NB. June 7 2012: We only glom segments that appear in an explicit mdo; +and leave those found in "do rec"'s intact. See +https://gitlab.haskell.org/ghc/ghc/issues/4148 for the discussion +leading to this design choice. Hence the test in segmentRecStmts. + +Note [Glomming segments] +~~~~~~~~~~~~~~~~~~~~~~~~ +Glomming the singleton segments of an mdo into minimal recursive groups. + +At first I thought this was just strongly connected components, but +there's an important constraint: the order of the stmts must not change. + +Consider + mdo { x <- ...y... + p <- z + y <- ...x... + q <- x + z <- y + r <- x } + +Here, the first stmt mention 'y', which is bound in the third. +But that means that the innocent second stmt (p <- z) gets caught +up in the recursion. And that in turn means that the binding for +'z' has to be included... and so on. + +Start at the tail { r <- x } +Now add the next one { z <- y ; r <- x } +Now add one more { q <- x ; z <- y ; r <- x } +Now one more... but this time we have to group a bunch into rec + { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x } +Now one more, which we can add on without a rec + { p <- z ; + rec { y <- ...x... ; q <- x ; z <- y } ; + r <- x } +Finally we add the last one; since it mentions y we have to +glom it together with the first two groups + { rec { x <- ...y...; p <- z ; y <- ...x... ; + q <- x ; z <- y } ; + r <- x } +-} + +glomSegments :: HsStmtContext Name + -> [Segment (LStmt GhcRn body)] + -> [Segment [LStmt GhcRn body]] + -- Each segment has a non-empty list of Stmts +-- See Note [Glomming segments] + +glomSegments _ [] = [] +glomSegments ctxt ((defs,uses,fwds,stmt) : segs) + -- Actually stmts will always be a singleton + = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others + where + segs' = glomSegments ctxt segs + (extras, others) = grab uses segs' + (ds, us, fs, ss) = unzip4 extras + + seg_defs = plusFVs ds `plusFV` defs + seg_uses = plusFVs us `plusFV` uses + seg_fwds = plusFVs fs `plusFV` fwds + seg_stmts = stmt : concat ss + + grab :: NameSet -- The client + -> [Segment a] + -> ([Segment a], -- Needed by the 'client' + [Segment a]) -- Not needed by the client + -- The result is simply a split of the input + grab uses dus + = (reverse yeses, reverse noes) + where + (noes, yeses) = span not_needed (reverse dus) + not_needed (defs,_,_,_) = not (intersectsNameSet defs uses) + +---------------------------------------------------- +segsToStmts :: Stmt GhcRn body + -- A RecStmt with the SyntaxOps filled in + -> [Segment [LStmt GhcRn body]] + -- Each Segment has a non-empty list of Stmts + -> FreeVars -- Free vars used 'later' + -> ([LStmt GhcRn body], FreeVars) + +segsToStmts _ [] fvs_later = ([], fvs_later) +segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later + = ASSERT( not (null ss) ) + (new_stmt : later_stmts, later_uses `plusFV` uses) + where + (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later + new_stmt | non_rec = head ss + | otherwise = L (getLoc (head ss)) rec_stmt + rec_stmt = empty_rec_stmt { recS_stmts = ss + , recS_later_ids = nameSetElemsStable used_later + , recS_rec_ids = nameSetElemsStable fwds } + -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] + non_rec = isSingleton ss && isEmptyNameSet fwds + used_later = defs `intersectNameSet` later_uses + -- The ones needed after the RecStmt + +{- +************************************************************************ +* * +ApplicativeDo +* * +************************************************************************ + +Note [ApplicativeDo] + += Example = + +For a sequence of statements + + do + x <- A + y <- B x + z <- C + return (f x y z) + +We want to transform this to + + (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C + +It would be easy to notice that "y <- B x" and "z <- C" are +independent and do something like this: + + do + x <- A + (y,z) <- (,) <$> B x <*> C + return (f x y z) + +But this isn't enough! A and C were also independent, and this +transformation loses the ability to do A and C in parallel. + +The algorithm works by first splitting the sequence of statements into +independent "segments", and a separate "tail" (the final statement). In +our example above, the segements would be + + [ x <- A + , y <- B x ] + + [ z <- C ] + +and the tail is: + + return (f x y z) + +Then we take these segments and make an Applicative expression from them: + + (\(x,y) z -> return (f x y z)) + <$> do { x <- A; y <- B x; return (x,y) } + <*> C + +Finally, we recursively apply the transformation to each segment, to +discover any nested parallelism. + += Syntax & spec = + + expr ::= ... | do {stmt_1; ..; stmt_n} expr | ... + + stmt ::= pat <- expr + | (arg_1 | ... | arg_n) -- applicative composition, n>=1 + | ... -- other kinds of statement (e.g. let) + + arg ::= pat <- expr + | {stmt_1; ..; stmt_n} {var_1..var_n} + +(note that in the actual implementation,the expr in a do statement is +represented by a LastStmt as the final stmt, this is just a +representational issue and may change later.) + +== Transformation to introduce applicative stmts == + +ado {} tail = tail +ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr' +ado {one} tail = one : tail +ado stmts tail + | n == 1 = ado before (ado after tail) + where (before,after) = split(stmts_1) + | n > 1 = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail + where + {stmts_1 .. stmts_n} = segments(stmts) + +segments(stmts) = + -- divide stmts into segments with no interdependencies + +mkArg({pat <- expr}) = (pat <- expr) +mkArg({stmt_1; ...; stmt_n}) = + {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)} + +split({stmt_1; ..; stmt_n) = + ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n}) + -- 1 <= i <= n + -- i is a good place to insert a bind + +== Desugaring for do == + +dsDo {} expr = expr + +dsDo {pat <- rhs; stmts} expr = + rhs >>= \pat -> dsDo stmts expr + +dsDo {(arg_1 | ... | arg_n)} (return expr) = + (\argpat (arg_1) .. argpat(arg_n) -> expr) + <$> argexpr(arg_1) + <*> ... + <*> argexpr(arg_n) + +dsDo {(arg_1 | ... | arg_n); stmts} expr = + join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr) + <$> argexpr(arg_1) + <*> ... + <*> argexpr(arg_n) + += Relevant modules in the rest of the compiler = + +ApplicativeDo touches a few phases in the compiler: + +* Renamer: The journey begins here in the renamer, where do-blocks are + scheduled as outlined above and transformed into applicative + combinators. However, the code is still represented as a do-block + with special forms of applicative statements. This allows us to + recover the original do-block when e.g. printing type errors, where + we don't want to show any of the applicative combinators since they + don't exist in the source code. + See ApplicativeStmt and ApplicativeArg in HsExpr. + +* Typechecker: ApplicativeDo passes through the typechecker much like any + other form of expression. The only crux is that the typechecker has to + be aware of the special ApplicativeDo statements in the do-notation, and + typecheck them appropriately. + Relevant module: TcMatches + +* Desugarer: Any do-block which contains applicative statements is desugared + as outlined above, to use the Applicative combinators. + Relevant module: DsExpr + +-} + +-- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and +-- 'pureName' due to @RebindableSyntax@. +data MonadNames = MonadNames { return_name, pure_name :: Name } + +instance Outputable MonadNames where + ppr (MonadNames {return_name=return_name,pure_name=pure_name}) = + hcat + [text "MonadNames { return_name = " + ,ppr return_name + ,text ", pure_name = " + ,ppr pure_name + ,text "}" + ] + +-- | rearrange a list of statements using ApplicativeDoStmt. See +-- Note [ApplicativeDo]. +rearrangeForApplicativeDo + :: HsStmtContext Name + -> [(ExprLStmt GhcRn, FreeVars)] + -> RnM ([ExprLStmt GhcRn], FreeVars) + +rearrangeForApplicativeDo _ [] = return ([], emptyNameSet) +rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet) +rearrangeForApplicativeDo ctxt stmts0 = do + optimal_ado <- goptM Opt_OptimalApplicativeDo + let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts + | otherwise = mkStmtTreeHeuristic stmts + traceRn "rearrangeForADo" (ppr stmt_tree) + return_name <- lookupSyntaxName' returnMName + pure_name <- lookupSyntaxName' pureAName + let monad_names = MonadNames { return_name = return_name + , pure_name = pure_name } + stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs + where + (stmts,(last,last_fvs)) = findLast stmts0 + findLast [] = error "findLast" + findLast [last] = ([],last) + findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs + +-- | A tree of statements using a mixture of applicative and bind constructs. +data StmtTree a + = StmtTreeOne a + | StmtTreeBind (StmtTree a) (StmtTree a) + | StmtTreeApplicative [StmtTree a] + +instance Outputable a => Outputable (StmtTree a) where + ppr (StmtTreeOne x) = parens (text "StmtTreeOne" <+> ppr x) + ppr (StmtTreeBind x y) = parens (hang (text "StmtTreeBind") + 2 (sep [ppr x, ppr y])) + ppr (StmtTreeApplicative xs) = parens (hang (text "StmtTreeApplicative") + 2 (vcat (map ppr xs))) + +flattenStmtTree :: StmtTree a -> [a] +flattenStmtTree t = go t [] + where + go (StmtTreeOne a) as = a : as + go (StmtTreeBind l r) as = go l (go r as) + go (StmtTreeApplicative ts) as = foldr go as ts + +type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars) +type Cost = Int + +-- | Turn a sequence of statements into an ExprStmtTree using a +-- heuristic algorithm. /O(n^2)/ +mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree +mkStmtTreeHeuristic [one] = StmtTreeOne one +mkStmtTreeHeuristic stmts = + case segments stmts of + [one] -> split one + segs -> StmtTreeApplicative (map split segs) + where + split [one] = StmtTreeOne one + split stmts = + StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after) + where (before, after) = splitSegment stmts + +-- | Turn a sequence of statements into an ExprStmtTree optimally, +-- using dynamic programming. /O(n^3)/ +mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree +mkStmtTreeOptimal stmts = + ASSERT(not (null stmts)) -- the empty case is handled by the caller; + -- we don't support empty StmtTrees. + fst (arr ! (0,n)) + where + n = length stmts - 1 + stmt_arr = listArray (0,n) stmts + + -- lazy cache of optimal trees for subsequences of the input + arr :: Array (Int,Int) (ExprStmtTree, Cost) + arr = array ((0,0),(n,n)) + [ ((lo,hi), tree lo hi) + | lo <- [0..n] + , hi <- [lo..n] ] + + -- compute the optimal tree for the sequence [lo..hi] + tree lo hi + | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1) + | otherwise = + case segments [ stmt_arr ! i | i <- [lo..hi] ] of + [] -> panic "mkStmtTree" + [_one] -> split lo hi + segs -> (StmtTreeApplicative trees, maximum costs) + where + bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs + (trees,costs) = unzip (map (uncurry split) (tail bounds)) + + -- find the best place to split the segment [lo..hi] + split :: Int -> Int -> (ExprStmtTree, Cost) + split lo hi + | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1) + | otherwise = (StmtTreeBind before after, c1+c2) + where + -- As per the paper, for a sequence s1...sn, we want to find + -- the split with the minimum cost, where the cost is the + -- sum of the cost of the left and right subsequences. + -- + -- As an optimisation (also in the paper) if the cost of + -- s1..s(n-1) is different from the cost of s2..sn, we know + -- that the optimal solution is the lower of the two. Only + -- in the case that these two have the same cost do we need + -- to do the exhaustive search. + -- + ((before,c1),(after,c2)) + | hi - lo == 1 + = ((StmtTreeOne (stmt_arr ! lo), 1), + (StmtTreeOne (stmt_arr ! hi), 1)) + | left_cost < right_cost + = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1)) + | left_cost > right_cost + = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost)) + | otherwise = minimumBy (comparing cost) alternatives + where + (left, left_cost) = arr ! (lo,hi-1) + (right, right_cost) = arr ! (lo+1,hi) + cost ((_,c1),(_,c2)) = c1 + c2 + alternatives = [ (arr ! (lo,k), arr ! (k+1,hi)) + | k <- [lo .. hi-1] ] + + +-- | Turn the ExprStmtTree back into a sequence of statements, using +-- ApplicativeStmt where necessary. +stmtTreeToStmts + :: MonadNames + -> HsStmtContext Name + -> ExprStmtTree + -> [ExprLStmt GhcRn] -- ^ the "tail" + -> FreeVars -- ^ free variables of the tail + -> RnM ( [ExprLStmt GhcRn] -- ( output statements, + , FreeVars ) -- , things we needed + +-- If we have a single bind, and we can do it without a join, transform +-- to an ApplicativeStmt. This corresponds to the rule +-- dsBlock [pat <- rhs] (return expr) = expr <$> rhs +-- In the spec, but we do it here rather than in the desugarer, +-- because we need the typechecker to typecheck the <$> form rather than +-- the bind form, which would give rise to a Monad constraint. +stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ fail_op), _)) + tail _tail_fvs + | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail + -- See Note [ApplicativeDo and strict patterns] + = mkApplicativeStmt ctxt [ApplicativeArgOne + { xarg_app_arg_one = noExtField + , app_arg_pattern = pat + , arg_expr = rhs + , is_body_stmt = False + , fail_operator = fail_op}] + False tail' +stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ fail_op),_)) + tail _tail_fvs + | (False,tail') <- needJoin monad_names tail + = mkApplicativeStmt ctxt + [ApplicativeArgOne + { xarg_app_arg_one = noExtField + , app_arg_pattern = nlWildPatName + , arg_expr = rhs + , is_body_stmt = True + , fail_operator = fail_op}] False tail' + +stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs = + return (s : tail, emptyNameSet) + +stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do + (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs + let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after)) + (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs + return (stmts2, fvs1 `plusFV` fvs2) + +stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do + pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees + let (stmts', fvss) = unzip pairs + let (need_join, tail') = + if any hasStrictPattern trees + then (True, tail) + else needJoin monad_names tail + + (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail' + return (stmts, unionNameSets (fvs:fvss)) + where + stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ fail_op), _)) + = return (ApplicativeArgOne + { xarg_app_arg_one = noExtField + , app_arg_pattern = pat + , arg_expr = exp + , is_body_stmt = False + , fail_operator = fail_op + }, emptyFVs) + stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ fail_op), _)) = + return (ApplicativeArgOne + { xarg_app_arg_one = noExtField + , app_arg_pattern = nlWildPatName + , arg_expr = exp + , is_body_stmt = True + , fail_operator = fail_op + }, emptyFVs) + stmtTreeArg ctxt tail_fvs tree = do + let stmts = flattenStmtTree tree + pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) + `intersectNameSet` tail_fvs + pvars = nameSetElemsStable pvarset + -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring] + pat = mkBigLHsVarPatTup pvars + tup = mkBigLHsVarTup pvars + (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset + (mb_ret, fvs1) <- + if | L _ ApplicativeStmt{} <- last stmts' -> + return (unLoc tup, emptyNameSet) + | otherwise -> do + ret <- lookupSyntaxName' returnMName + let expr = HsApp noExtField (noLoc (HsVar noExtField (noLoc ret))) tup + return (expr, emptyFVs) + return ( ApplicativeArgMany + { xarg_app_arg_many = noExtField + , app_stmts = stmts' + , final_expr = mb_ret + , bv_pattern = pat + } + , fvs1 `plusFV` fvs2) + + +-- | Divide a sequence of statements into segments, where no segment +-- depends on any variables defined by a statement in another segment. +segments + :: [(ExprLStmt GhcRn, FreeVars)] + -> [[(ExprLStmt GhcRn, FreeVars)]] +segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts) + where + allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) + + -- We would rather not have a segment that just has LetStmts in + -- it, so combine those with an adjacent segment where possible. + merge [] = [] + merge (seg : segs) + = case rest of + [] -> [(seg,all_lets)] + ((s,s_lets):ss) | all_lets || s_lets + -> (seg ++ s, all_lets && s_lets) : ss + _otherwise -> (seg,all_lets) : rest + where + rest = merge segs + all_lets = all (isLetStmt . fst) seg + + -- walk splits the statement sequence into segments, traversing + -- the sequence from the back to the front, and keeping track of + -- the set of free variables of the current segment. Whenever + -- this set of free variables is empty, we have a complete segment. + walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]] + walk [] = [] + walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest + where (seg,rest) = chunter fvs' stmts + (_, fvs') = stmtRefs stmt fvs + + chunter _ [] = ([], []) + chunter vars ((stmt,fvs) : rest) + | not (isEmptyNameSet vars) + || isStrictPatternBind stmt + -- See Note [ApplicativeDo and strict patterns] + = ((stmt,fvs) : chunk, rest') + where (chunk,rest') = chunter vars' rest + (pvars, evars) = stmtRefs stmt fvs + vars' = (vars `minusNameSet` pvars) `unionNameSet` evars + chunter _ rest = ([], rest) + + stmtRefs stmt fvs + | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars) + | otherwise = (pvars, fvs') + where fvs' = fvs `intersectNameSet` allvars + pvars = mkNameSet (collectStmtBinders (unLoc stmt)) + + isStrictPatternBind :: ExprLStmt GhcRn -> Bool + isStrictPatternBind (L _ (BindStmt _ pat _ _ _)) = isStrictPattern pat + isStrictPatternBind _ = False + +{- +Note [ApplicativeDo and strict patterns] + +A strict pattern match is really a dependency. For example, + +do + (x,y) <- A + z <- B + return C + +The pattern (_,_) must be matched strictly before we do B. If we +allowed this to be transformed into + + (\(x,y) -> \z -> C) <$> A <*> B + +then it could be lazier than the standard desuraging using >>=. See #13875 +for more examples. + +Thus, whenever we have a strict pattern match, we treat it as a +dependency between that statement and the following one. The +dependency prevents those two statements from being performed "in +parallel" in an ApplicativeStmt, but doesn't otherwise affect what we +can do with the rest of the statements in the same "do" expression. +-} + +isStrictPattern :: LPat (GhcPass p) -> Bool +isStrictPattern lpat = + case unLoc lpat of + WildPat{} -> False + VarPat{} -> False + LazyPat{} -> False + AsPat _ _ p -> isStrictPattern p + ParPat _ p -> isStrictPattern p + ViewPat _ _ p -> isStrictPattern p + SigPat _ p _ -> isStrictPattern p + BangPat{} -> True + ListPat{} -> True + TuplePat{} -> True + SumPat{} -> True + ConPatIn{} -> True + ConPatOut{} -> True + LitPat{} -> True + NPat{} -> True + NPlusKPat{} -> True + SplicePat{} -> True + _otherwise -> panic "isStrictPattern" + +hasStrictPattern :: ExprStmtTree -> Bool +hasStrictPattern (StmtTreeOne (L _ (BindStmt _ pat _ _ _), _)) = isStrictPattern pat +hasStrictPattern (StmtTreeOne _) = False +hasStrictPattern (StmtTreeBind a b) = hasStrictPattern a || hasStrictPattern b +hasStrictPattern (StmtTreeApplicative trees) = any hasStrictPattern trees + + +isLetStmt :: LStmt a b -> Bool +isLetStmt (L _ LetStmt{}) = True +isLetStmt _ = False + +-- | Find a "good" place to insert a bind in an indivisible segment. +-- This is the only place where we use heuristics. The current +-- heuristic is to peel off the first group of independent statements +-- and put the bind after those. +splitSegment + :: [(ExprLStmt GhcRn, FreeVars)] + -> ( [(ExprLStmt GhcRn, FreeVars)] + , [(ExprLStmt GhcRn, FreeVars)] ) +splitSegment [one,two] = ([one],[two]) + -- there is no choice when there are only two statements; this just saves + -- some work in a common case. +splitSegment stmts + | Just (lets,binds,rest) <- slurpIndependentStmts stmts + = if not (null lets) + then (lets, binds++rest) + else (lets++binds, rest) + | otherwise + = case stmts of + (x:xs) -> ([x],xs) + _other -> (stmts,[]) + +slurpIndependentStmts + :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] + -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts + , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts + , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] ) +slurpIndependentStmts stmts = go [] [] emptyNameSet stmts + where + -- If we encounter a BindStmt that doesn't depend on a previous BindStmt + -- in this group, then add it to the group. We have to be careful about + -- strict patterns though; splitSegments expects that if we return Just + -- then we have actually done some splitting. Otherwise it will go into + -- an infinite loop (#14163). + go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest) + | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat) + = go lets ((L loc (BindStmt noExtField pat body bind_op fail_op), fvs) : indep) + bndrs' rest + where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat) + -- If we encounter a LetStmt that doesn't depend on a BindStmt in this + -- group, then move it to the beginning, so that it doesn't interfere with + -- grouping more BindStmts. + -- TODO: perhaps we shouldn't do this if there are any strict bindings, + -- because we might be moving evaluation earlier. + go lets indep bndrs ((L loc (LetStmt noExtField binds), fvs) : rest) + | isEmptyNameSet (bndrs `intersectNameSet` fvs) + = go ((L loc (LetStmt noExtField binds), fvs) : lets) indep bndrs rest + go _ [] _ _ = Nothing + go _ [_] _ _ = Nothing + go lets indep _ stmts = Just (reverse lets, reverse indep, stmts) + +-- | Build an ApplicativeStmt, and strip the "return" from the tail +-- if necessary. +-- +-- For example, if we start with +-- do x <- E1; y <- E2; return (f x y) +-- then we get +-- do (E1[x] | E2[y]); f x y +-- +-- the LastStmt in this case has the return removed, but we set the +-- flag on the LastStmt to indicate this, so that we can print out the +-- original statement correctly in error messages. It is easier to do +-- it this way rather than try to ignore the return later in both the +-- typechecker and the desugarer (I tried it that way first!). +mkApplicativeStmt + :: HsStmtContext Name + -> [ApplicativeArg GhcRn] -- ^ The args + -> Bool -- ^ True <=> need a join + -> [ExprLStmt GhcRn] -- ^ The body statements + -> RnM ([ExprLStmt GhcRn], FreeVars) +mkApplicativeStmt ctxt args need_join body_stmts + = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName + ; (ap_op, fvs2) <- lookupStmtName ctxt apAName + ; (mb_join, fvs3) <- + if need_join then + do { (join_op, fvs) <- lookupStmtName ctxt joinMName + ; return (Just join_op, fvs) } + else + return (Nothing, emptyNameSet) + ; let applicative_stmt = noLoc $ ApplicativeStmt noExtField + (zip (fmap_op : repeat ap_op) args) + mb_join + ; return ( applicative_stmt : body_stmts + , fvs1 `plusFV` fvs2 `plusFV` fvs3) } + +-- | Given the statements following an ApplicativeStmt, determine whether +-- we need a @join@ or not, and remove the @return@ if necessary. +needJoin :: MonadNames + -> [ExprLStmt GhcRn] + -> (Bool, [ExprLStmt GhcRn]) +needJoin _monad_names [] = (False, []) -- we're in an ApplicativeArg +needJoin monad_names [L loc (LastStmt _ e _ t)] + | Just arg <- isReturnApp monad_names e = + (False, [L loc (LastStmt noExtField arg True t)]) +needJoin _monad_names stmts = (True, stmts) + +-- | @Just e@, if the expression is @return e@ or @return $ e@, +-- otherwise @Nothing@ +isReturnApp :: MonadNames + -> LHsExpr GhcRn + -> Maybe (LHsExpr GhcRn) +isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr +isReturnApp monad_names (L _ e) = case e of + OpApp _ l op r | is_return l, is_dollar op -> Just r + HsApp _ f arg | is_return f -> Just arg + _otherwise -> Nothing + where + is_var f (L _ (HsPar _ e)) = is_var f e + is_var f (L _ (HsAppType _ e _)) = is_var f e + is_var f (L _ (HsVar _ (L _ r))) = f r + -- TODO: I don't know how to get this right for rebindable syntax + is_var _ _ = False + + is_return = is_var (\n -> n == return_name monad_names + || n == pure_name monad_names) + is_dollar = is_var (`hasKey` dollarIdKey) + +{- +************************************************************************ +* * +\subsubsection{Errors} +* * +************************************************************************ +-} + +checkEmptyStmts :: HsStmtContext Name -> RnM () +-- We've seen an empty sequence of Stmts... is that ok? +checkEmptyStmts ctxt + = unless (okEmpty ctxt) (addErr (emptyErr ctxt)) + +okEmpty :: HsStmtContext a -> Bool +okEmpty (PatGuard {}) = True +okEmpty _ = False + +emptyErr :: HsStmtContext Name -> SDoc +emptyErr (ParStmtCtxt {}) = text "Empty statement group in parallel comprehension" +emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'" +emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt + +---------------------- +checkLastStmt :: Outputable (body GhcPs) => HsStmtContext Name + -> LStmt GhcPs (Located (body GhcPs)) + -> RnM (LStmt GhcPs (Located (body GhcPs))) +checkLastStmt ctxt lstmt@(L loc stmt) + = case ctxt of + ListComp -> check_comp + MonadComp -> check_comp + ArrowExpr -> check_do + DoExpr -> check_do + MDoExpr -> check_do + _ -> check_other + where + check_do -- Expect BodyStmt, and change it to LastStmt + = case stmt of + BodyStmt _ e _ _ -> return (L loc (mkLastStmt e)) + LastStmt {} -> return lstmt -- "Deriving" clauses may generate a + -- LastStmt directly (unlike the parser) + _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } + last_error = (text "The last statement in" <+> pprAStmtContext ctxt + <+> text "must be an expression") + + check_comp -- Expect LastStmt; this should be enforced by the parser! + = case stmt of + LastStmt {} -> return lstmt + _ -> pprPanic "checkLastStmt" (ppr lstmt) + + check_other -- Behave just as if this wasn't the last stmt + = do { checkStmt ctxt lstmt; return lstmt } + +-- Checking when a particular Stmt is ok +checkStmt :: HsStmtContext Name + -> LStmt GhcPs (Located (body GhcPs)) + -> RnM () +checkStmt ctxt (L _ stmt) + = do { dflags <- getDynFlags + ; case okStmt dflags ctxt stmt of + IsValid -> return () + NotValid extra -> addErr (msg $$ extra) } + where + msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement") + , text "in" <+> pprAStmtContext ctxt ] + +pprStmtCat :: Stmt (GhcPass a) body -> SDoc +pprStmtCat (TransStmt {}) = text "transform" +pprStmtCat (LastStmt {}) = text "return expression" +pprStmtCat (BodyStmt {}) = text "body" +pprStmtCat (BindStmt {}) = text "binding" +pprStmtCat (LetStmt {}) = text "let" +pprStmtCat (RecStmt {}) = text "rec" +pprStmtCat (ParStmt {}) = text "parallel" +pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt" +pprStmtCat (XStmtLR nec) = noExtCon nec + +------------ +emptyInvalid :: Validity -- Payload is the empty document +emptyInvalid = NotValid Outputable.empty + +okStmt, okDoStmt, okCompStmt, okParStmt + :: DynFlags -> HsStmtContext Name + -> Stmt GhcPs (Located (body GhcPs)) -> Validity +-- Return Nothing if OK, (Just extra) if not ok +-- The "extra" is an SDoc that is appended to a generic error message + +okStmt dflags ctxt stmt + = case ctxt of + PatGuard {} -> okPatGuardStmt stmt + ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt + DoExpr -> okDoStmt dflags ctxt stmt + MDoExpr -> okDoStmt dflags ctxt stmt + ArrowExpr -> okDoStmt dflags ctxt stmt + GhciStmtCtxt -> okDoStmt dflags ctxt stmt + ListComp -> okCompStmt dflags ctxt stmt + MonadComp -> okCompStmt dflags ctxt stmt + TransStmtCtxt ctxt -> okStmt dflags ctxt stmt + +------------- +okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity +okPatGuardStmt stmt + = case stmt of + BodyStmt {} -> IsValid + BindStmt {} -> IsValid + LetStmt {} -> IsValid + _ -> emptyInvalid + +------------- +okParStmt dflags ctxt stmt + = case stmt of + LetStmt _ (L _ (HsIPBinds {})) -> emptyInvalid + _ -> okStmt dflags ctxt stmt + +---------------- +okDoStmt dflags ctxt stmt + = case stmt of + RecStmt {} + | LangExt.RecursiveDo `xopt` dflags -> IsValid + | ArrowExpr <- ctxt -> IsValid -- Arrows allows 'rec' + | otherwise -> NotValid (text "Use RecursiveDo") + BindStmt {} -> IsValid + LetStmt {} -> IsValid + BodyStmt {} -> IsValid + _ -> emptyInvalid + +---------------- +okCompStmt dflags _ stmt + = case stmt of + BindStmt {} -> IsValid + LetStmt {} -> IsValid + BodyStmt {} -> IsValid + ParStmt {} + | LangExt.ParallelListComp `xopt` dflags -> IsValid + | otherwise -> NotValid (text "Use ParallelListComp") + TransStmt {} + | LangExt.TransformListComp `xopt` dflags -> IsValid + | otherwise -> NotValid (text "Use TransformListComp") + RecStmt {} -> emptyInvalid + LastStmt {} -> emptyInvalid -- Should not happen (dealt with by checkLastStmt) + ApplicativeStmt {} -> emptyInvalid + XStmtLR nec -> noExtCon nec + +--------- +checkTupleSection :: [LHsTupArg GhcPs] -> RnM () +checkTupleSection args + = do { tuple_section <- xoptM LangExt.TupleSections + ; checkErr (all tupArgPresent args || tuple_section) msg } + where + msg = text "Illegal tuple section: use TupleSections" + +--------- +sectionErr :: HsExpr GhcPs -> SDoc +sectionErr expr + = hang (text "A section must be enclosed in parentheses") + 2 (text "thus:" <+> (parens (ppr expr))) + +badIpBinds :: Outputable a => SDoc -> a -> SDoc +badIpBinds what binds + = hang (text "Implicit-parameter bindings illegal in" <+> what) + 2 (ppr binds) + +--------- + +monadFailOp :: LPat GhcPs + -> HsStmtContext Name + -> RnM (SyntaxExpr GhcRn, FreeVars) +monadFailOp pat ctxt + -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.) + -- we should not need to fail. + | isIrrefutableHsPat pat = return (noSyntaxExpr, emptyFVs) + + -- For non-monadic contexts (e.g. guard patterns, list + -- comprehensions, etc.) we should not need to fail. See Note + -- [Failing pattern matches in Stmts] + | not (isMonadFailStmtContext ctxt) = return (noSyntaxExpr, emptyFVs) + + | otherwise = getMonadFailOp + +{- +Note [Monad fail : Rebindable syntax, overloaded strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Given the code + foo x = do { Just y <- x; return y } + +we expect it to desugar as + foo x = x >>= \r -> case r of + Just y -> return y + Nothing -> fail "Pattern match error" + +But with RebindableSyntax and OverloadedStrings, we really want +it to desugar thus: + foo x = x >>= \r -> case r of + Just y -> return y + Nothing -> fail (fromString "Patterm match error") + +So, in this case, we synthesize the function + \x -> fail (fromString x) + +(rather than plain 'fail') for the 'fail' operation. This is done in +'getMonadFailOp'. +-} +getMonadFailOp :: RnM (SyntaxExpr GhcRn, FreeVars) -- Syntax expr fail op +getMonadFailOp + = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags + ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags + ; reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings + } + where + reallyGetMonadFailOp rebindableSyntax overloadedStrings + | rebindableSyntax && overloadedStrings = do + (failExpr, failFvs) <- lookupSyntaxName failMName + (fromStringExpr, fromStringFvs) <- lookupSyntaxName fromStringName + let arg_lit = fsLit "arg" + arg_name = mkSystemVarName (mkVarOccUnique arg_lit) arg_lit + arg_syn_expr = mkRnSyntaxExpr arg_name + let body :: LHsExpr GhcRn = + nlHsApp (noLoc $ syn_expr failExpr) + (nlHsApp (noLoc $ syn_expr fromStringExpr) + (noLoc $ syn_expr arg_syn_expr)) + let failAfterFromStringExpr :: HsExpr GhcRn = + unLoc $ mkHsLam [noLoc $ VarPat noExtField $ noLoc arg_name] body + let failAfterFromStringSynExpr :: SyntaxExpr GhcRn = + mkSyntaxExpr failAfterFromStringExpr + return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs) + | otherwise = lookupSyntaxName failMName diff --git a/compiler/GHC/Rename/Expr.hs-boot b/compiler/GHC/Rename/Expr.hs-boot new file mode 100644 index 0000000000..9667b5b26c --- /dev/null +++ b/compiler/GHC/Rename/Expr.hs-boot @@ -0,0 +1,17 @@ +module GHC.Rename.Expr where +import Name +import GHC.Hs +import NameSet ( FreeVars ) +import TcRnTypes +import SrcLoc ( Located ) +import Outputable ( Outputable ) + +rnLExpr :: LHsExpr GhcPs + -> RnM (LHsExpr GhcRn, FreeVars) + +rnStmts :: --forall thing body. + Outputable (body GhcPs) => HsStmtContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> [LStmt GhcPs (Located (body GhcPs))] + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) diff --git a/compiler/GHC/Rename/Fixity.hs b/compiler/GHC/Rename/Fixity.hs new file mode 100644 index 0000000000..884e2593d0 --- /dev/null +++ b/compiler/GHC/Rename/Fixity.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE ViewPatterns #-} + +{- + +This module contains code which maintains and manipulates the +fixity environment during renaming. + +-} +module GHC.Rename.Fixity + ( MiniFixityEnv + , addLocalFixities + , lookupFixityRn + , lookupFixityRn_help + , lookupFieldFixityRn + , lookupTyFixityRn + ) +where + +import GhcPrelude + +import GHC.Iface.Load +import GHC.Hs +import RdrName +import HscTypes +import TcRnMonad +import Name +import NameEnv +import Module +import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence, + defaultFixity, SourceText(..) ) +import SrcLoc +import Outputable +import Maybes +import Data.List +import Data.Function ( on ) +import GHC.Rename.Unbound + +{- +********************************************************* +* * + Fixities +* * +********************************************************* + +Note [Fixity signature lookup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A fixity declaration like + + infixr 2 ? + +can refer to a value-level operator, e.g.: + + (?) :: String -> String -> String + +or a type-level operator, like: + + data (?) a b = A a | B b + +so we extend the lookup of the reader name '?' to the TcClsName namespace, as +well as the original namespace. + +The extended lookup is also used in other places, like resolution of +deprecation declarations, and lookup of names in GHCi. +-} + +-------------------------------- +type MiniFixityEnv = FastStringEnv (Located Fixity) + -- Mini fixity env for the names we're about + -- to bind, in a single binding group + -- + -- It is keyed by the *FastString*, not the *OccName*, because + -- the single fixity decl infix 3 T + -- affects both the data constructor T and the type constrctor T + -- + -- We keep the location so that if we find + -- a duplicate, we can report it sensibly + +-------------------------------- +-- Used for nested fixity decls to bind names along with their fixities. +-- the fixities are given as a UFM from an OccName's FastString to a fixity decl + +addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a +addLocalFixities mini_fix_env names thing_inside + = extendFixityEnv (mapMaybe find_fixity names) thing_inside + where + find_fixity name + = case lookupFsEnv mini_fix_env (occNameFS occ) of + Just lfix -> Just (name, FixItem occ (unLoc lfix)) + Nothing -> Nothing + where + occ = nameOccName name + +{- +-------------------------------- +lookupFixity is a bit strange. + +* Nested local fixity decls are put in the local fixity env, which we + find with getFixtyEnv + +* Imported fixities are found in the PIT + +* Top-level fixity decls in this module may be for Names that are + either Global (constructors, class operations) + or Local/Exported (everything else) + (See notes with GHC.Rename.Names.getLocalDeclBinders for why we have this split.) + We put them all in the local fixity environment +-} + +lookupFixityRn :: Name -> RnM Fixity +lookupFixityRn name = lookupFixityRn' name (nameOccName name) + +lookupFixityRn' :: Name -> OccName -> RnM Fixity +lookupFixityRn' name = fmap snd . lookupFixityRn_help' name + +-- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity' +-- in a local environment or from an interface file. Otherwise, it returns +-- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without +-- user-supplied fixity declarations). +lookupFixityRn_help :: Name + -> RnM (Bool, Fixity) +lookupFixityRn_help name = + lookupFixityRn_help' name (nameOccName name) + +lookupFixityRn_help' :: Name + -> OccName + -> RnM (Bool, Fixity) +lookupFixityRn_help' name occ + | isUnboundName name + = return (False, Fixity NoSourceText minPrecedence InfixL) + -- Minimise errors from ubound names; eg + -- a>0 `foo` b>0 + -- where 'foo' is not in scope, should not give an error (#7937) + + | otherwise + = do { local_fix_env <- getFixityEnv + ; case lookupNameEnv local_fix_env name of { + Just (FixItem _ fix) -> return (True, fix) ; + Nothing -> + + do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod name + -- Local (and interactive) names are all in the + -- fixity env, and don't have entries in the HPT + then return (False, defaultFixity) + else lookup_imported } } } + where + lookup_imported + -- For imported names, we have to get their fixities by doing a + -- loadInterfaceForName, and consulting the Ifaces that comes back + -- from that, because the interface file for the Name might not + -- have been loaded yet. Why not? Suppose you import module A, + -- which exports a function 'f', thus; + -- module CurrentModule where + -- import A( f ) + -- module A( f ) where + -- import B( f ) + -- Then B isn't loaded right away (after all, it's possible that + -- nothing from B will be used). When we come across a use of + -- 'f', we need to know its fixity, and it's then, and only + -- then, that we load B.hi. That is what's happening here. + -- + -- loadInterfaceForName will find B.hi even if B is a hidden module, + -- and that's what we want. + = do { iface <- loadInterfaceForName doc name + ; let mb_fix = mi_fix_fn (mi_final_exts iface) occ + ; let msg = case mb_fix of + Nothing -> + text "looking up name" <+> ppr name + <+> text "in iface, but found no fixity for it." + <+> text "Using default fixity instead." + Just f -> + text "looking up name in iface and found:" + <+> vcat [ppr name, ppr f] + ; traceRn "lookupFixityRn_either:" msg + ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix) } + + doc = text "Checking fixity for" <+> ppr name + +--------------- +lookupTyFixityRn :: Located Name -> RnM Fixity +lookupTyFixityRn = lookupFixityRn . unLoc + +-- | Look up the fixity of a (possibly ambiguous) occurrence of a record field +-- selector. We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as +-- the field label, which might be different to the 'OccName' of the selector +-- 'Name' if @DuplicateRecordFields@ is in use (#1173). If there are +-- multiple possible selectors with different fixities, generate an error. +lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity +lookupFieldFixityRn (Unambiguous n lrdr) + = lookupFixityRn' n (rdrNameOcc (unLoc lrdr)) +lookupFieldFixityRn (Ambiguous _ lrdr) = get_ambiguous_fixity (unLoc lrdr) + where + get_ambiguous_fixity :: RdrName -> RnM Fixity + get_ambiguous_fixity rdr_name = do + traceRn "get_ambiguous_fixity" (ppr rdr_name) + rdr_env <- getGlobalRdrEnv + let elts = lookupGRE_RdrName rdr_name rdr_env + + fixities <- groupBy ((==) `on` snd) . zip elts + <$> mapM lookup_gre_fixity elts + + case fixities of + -- There should always be at least one fixity. + -- Something's very wrong if there are no fixity candidates, so panic + [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName" + [ (_, fix):_ ] -> return fix + ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs) + >> return (Fixity NoSourceText minPrecedence InfixL) + + lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre) + + ambiguous_fixity_err rn ambigs + = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn) + , hang (text "Conflicts: ") 2 . vcat . + map format_ambig $ concat ambigs ] + + format_ambig (elt, fix) = hang (ppr fix) + 2 (pprNameProvenance elt) +lookupFieldFixityRn (XAmbiguousFieldOcc nec) = noExtCon nec diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs new file mode 100644 index 0000000000..9ead354935 --- /dev/null +++ b/compiler/GHC/Rename/Names.hs @@ -0,0 +1,1783 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Extracting imported and top-level names in scope +-} + +{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Rename.Names ( + rnImports, getLocalNonValBinders, newRecordSelector, + extendGlobalRdrEnvRn, + gresFromAvails, + calculateAvails, + reportUnusedNames, + checkConName, + mkChildEnv, + findChildren, + dodgyMsg, + dodgyMsgInsert, + findImportUsage, + getMinimalImports, + printMinimalImports, + ImportDeclUsage + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import DynFlags +import TyCoPpr +import GHC.Hs +import TcEnv +import GHC.Rename.Env +import GHC.Rename.Fixity +import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv ) +import GHC.Iface.Load ( loadSrcInterface ) +import TcRnMonad +import PrelNames +import Module +import Name +import NameEnv +import NameSet +import Avail +import FieldLabel +import HscTypes +import RdrName +import RdrHsSyn ( setRdrNameSpace ) +import Outputable +import Maybes +import SrcLoc +import BasicTypes ( TopLevelFlag(..), StringLiteral(..) ) +import Util +import FastString +import FastStringEnv +import Id +import Type +import PatSyn +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Data.Either ( partitionEithers, isRight, rights ) +import Data.Map ( Map ) +import qualified Data.Map as Map +import Data.Ord ( comparing ) +import Data.List ( partition, (\\), find, sortBy ) +import qualified Data.Set as S +import System.FilePath ((</>)) + +import System.IO + +{- +************************************************************************ +* * +\subsection{rnImports} +* * +************************************************************************ + +Note [Tracking Trust Transitively] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we import a package as well as checking that the direct imports are safe +according to the rules outlined in the Note [HscMain . Safe Haskell Trust Check] +we must also check that these rules hold transitively for all dependent modules +and packages. Doing this without caching any trust information would be very +slow as we would need to touch all packages and interface files a module depends +on. To avoid this we make use of the property that if a modules Safe Haskell +mode changes, this triggers a recompilation from that module in the dependcy +graph. So we can just worry mostly about direct imports. + +There is one trust property that can change for a package though without +recompilation being triggered: package trust. So we must check that all +packages a module tranitively depends on to be trusted are still trusted when +we are compiling this module (as due to recompilation avoidance some modules +below may not be considered trusted any more without recompilation being +triggered). + +We handle this by augmenting the existing transitive list of packages a module M +depends on with a bool for each package that says if it must be trusted when the +module M is being checked for trust. This list of trust required packages for a +single import is gathered in the rnImportDecl function and stored in an +ImportAvails data structure. The union of these trust required packages for all +imports is done by the rnImports function using the combine function which calls +the plusImportAvails function that is a union operation for the ImportAvails +type. This gives us in an ImportAvails structure all packages required to be +trusted for the module we are currently compiling. Checking that these packages +are still trusted (and that direct imports are trusted) is done in +HscMain.checkSafeImports. + +See the note below, [Trust Own Package] for a corner case in this method and +how its handled. + + +Note [Trust Own Package] +~~~~~~~~~~~~~~~~~~~~~~~~ +There is a corner case of package trust checking that the usual transitive check +doesn't cover. (For how the usual check operates see the Note [Tracking Trust +Transitively] below). The case is when you import a -XSafe module M and M +imports a -XTrustworthy module N. If N resides in a different package than M, +then the usual check works as M will record a package dependency on N's package +and mark it as required to be trusted. If N resides in the same package as M +though, then importing M should require its own package be trusted due to N +(since M is -XSafe so doesn't create this requirement by itself). The usual +check fails as a module doesn't record a package dependency of its own package. +So instead we now have a bool field in a modules interface file that simply +states if the module requires its own package to be trusted. This field avoids +us having to load all interface files that the module depends on to see if one +is trustworthy. + + +Note [Trust Transitive Property] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +So there is an interesting design question in regards to transitive trust +checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch +of modules and packages, some packages it requires to be trusted as its using +-XTrustworthy modules from them. Now if I have a module A that doesn't use safe +haskell at all and simply imports B, should A inherit all the trust +requirements from B? Should A now also require that a package p is trusted since +B required it? + +We currently say no but saying yes also makes sense. The difference is, if a +module M that doesn't use Safe Haskell imports a module N that does, should all +the trusted package requirements be dropped since M didn't declare that it cares +about Safe Haskell (so -XSafe is more strongly associated with the module doing +the importing) or should it be done still since the author of the module N that +uses Safe Haskell said they cared (so -XSafe is more strongly associated with +the module that was compiled that used it). + +Going with yes is a simpler semantics we think and harder for the user to stuff +up but it does mean that Safe Haskell will affect users who don't care about +Safe Haskell as they might grab a package from Cabal which uses safe haskell (say +network) and that packages imports -XTrustworthy modules from another package +(say bytestring), so requires that package is trusted. The user may now get +compilation errors in code that doesn't do anything with Safe Haskell simply +because they are using the network package. They will have to call 'ghc-pkg +trust network' to get everything working. Due to this invasive nature of going +with yes we have gone with no for now. +-} + +-- | Process Import Decls. See 'rnImportDecl' for a description of what +-- the return types represent. +-- Note: Do the non SOURCE ones first, so that we get a helpful warning +-- for SOURCE ones that are unnecessary +rnImports :: [LImportDecl GhcPs] + -> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) +rnImports imports = do + tcg_env <- getGblEnv + -- NB: want an identity module here, because it's OK for a signature + -- module to import from its implementor + let this_mod = tcg_mod tcg_env + let (source, ordinary) = partition is_source_import imports + is_source_import d = ideclSource (unLoc d) + stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary + stuff2 <- mapAndReportM (rnImportDecl this_mod) source + -- Safe Haskell: See Note [Tracking Trust Transitively] + let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2) + return (decls, rdr_env, imp_avails, hpc_usage) + + where + -- See Note [Combining ImportAvails] + combine :: [(LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)] + -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) + combine ss = + let (decls, rdr_env, imp_avails, hpc_usage, finsts) = foldr + plus + ([], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet) + ss + in (decls, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts }, + hpc_usage) + + plus (decl, gbl_env1, imp_avails1, hpc_usage1) + (decls, gbl_env2, imp_avails2, hpc_usage2, finsts_set) + = ( decl:decls, + gbl_env1 `plusGlobalRdrEnv` gbl_env2, + imp_avails1' `plusImportAvails` imp_avails2, + hpc_usage1 || hpc_usage2, + extendModuleSetList finsts_set new_finsts ) + where + imp_avails1' = imp_avails1 { imp_finsts = [] } + new_finsts = imp_finsts imp_avails1 + +{- +Note [Combining ImportAvails] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +imp_finsts in ImportAvails is a list of family instance modules +transitively depended on by an import. imp_finsts for a currently +compiled module is a union of all the imp_finsts of imports. +Computing the union of two lists of size N is O(N^2) and if we +do it to M imports we end up with O(M*N^2). That can get very +expensive for bigger module hierarchies. + +Union can be optimized to O(N log N) if we use a Set. +imp_finsts is converted back and forth between dep_finsts, so +changing a type of imp_finsts means either paying for the conversions +or changing the type of dep_finsts as well. + +I've measured that the conversions would cost 20% of allocations on my +test case, so that can be ruled out. + +Changing the type of dep_finsts forces checkFamInsts to +get the module lists in non-deterministic order. If we wanted to restore +the deterministic order, we'd have to sort there, which is an additional +cost. As far as I can tell, using a non-deterministic order is fine there, +but that's a brittle nonlocal property which I'd like to avoid. + +Additionally, dep_finsts is read from an interface file, so its "natural" +type is a list. Which makes it a natural type for imp_finsts. + +Since rnImports.combine is really the only place that would benefit from +it being a Set, it makes sense to optimize the hot loop in rnImports.combine +without changing the representation. + +So here's what we do: instead of naively merging ImportAvails with +plusImportAvails in a loop, we make plusImportAvails merge empty imp_finsts +and compute the union on the side using Sets. When we're done, we can +convert it back to a list. One nice side effect of this approach is that +if there's a lot of overlap in the imp_finsts of imports, the +Set doesn't really need to grow and we don't need to allocate. + +Running generateModules from #14693 with DEPTH=16, WIDTH=30 finishes in +23s before, and 11s after. +-} + + + +-- | Given a located import declaration @decl@ from @this_mod@, +-- calculate the following pieces of information: +-- +-- 1. An updated 'LImportDecl', where all unresolved 'RdrName' in +-- the entity lists have been resolved into 'Name's, +-- +-- 2. A 'GlobalRdrEnv' representing the new identifiers that were +-- brought into scope (taking into account module qualification +-- and hiding), +-- +-- 3. 'ImportAvails' summarizing the identifiers that were imported +-- by this declaration, and +-- +-- 4. A boolean 'AnyHpcUsage' which is true if the imported module +-- used HPC. +rnImportDecl :: Module -> LImportDecl GhcPs + -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage) +rnImportDecl this_mod + (L loc decl@(ImportDecl { ideclExt = noExtField + , ideclName = loc_imp_mod_name + , ideclPkgQual = mb_pkg + , ideclSource = want_boot, ideclSafe = mod_safe + , ideclQualified = qual_style, ideclImplicit = implicit + , ideclAs = as_mod, ideclHiding = imp_details })) + = setSrcSpan loc $ do + + when (isJust mb_pkg) $ do + pkg_imports <- xoptM LangExt.PackageImports + when (not pkg_imports) $ addErr packageImportErr + + let qual_only = isImportDeclQualified qual_style + + -- If there's an error in loadInterface, (e.g. interface + -- file not found) we get lots of spurious errors from 'filterImports' + let imp_mod_name = unLoc loc_imp_mod_name + doc = ppr imp_mod_name <+> text "is directly imported" + + -- Check for self-import, which confuses the typechecker (#9032) + -- ghc --make rejects self-import cycles already, but batch-mode may not + -- at least not until GHC.IfaceToCore.tcHiBootIface, which is too late to avoid + -- typechecker crashes. (Indirect self imports are not caught until + -- GHC.IfaceToCore, see #10337 tracking how to make this error better.) + -- + -- Originally, we also allowed 'import {-# SOURCE #-} M', but this + -- caused bug #10182: in one-shot mode, we should never load an hs-boot + -- file for the module we are compiling into the EPS. In principle, + -- it should be possible to support this mode of use, but we would have to + -- extend Provenance to support a local definition in a qualified location. + -- For now, we don't support it, but see #10336 + when (imp_mod_name == moduleName this_mod && + (case mb_pkg of -- If we have import "<pkg>" M, then we should + -- check that "<pkg>" is "this" (which is magic) + -- or the name of this_mod's package. Yurgh! + -- c.f. GHC.findModule, and #9997 + Nothing -> True + Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" || + fsToUnitId pkg_fs == moduleUnitId this_mod)) + (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name)) + + -- Check for a missing import list (Opt_WarnMissingImportList also + -- checks for T(..) items but that is done in checkDodgyImport below) + case imp_details of + Just (False, _) -> return () -- Explicit import list + _ | implicit -> return () -- Do not bleat for implicit imports + | qual_only -> return () + | otherwise -> whenWOptM Opt_WarnMissingImportList $ + addWarn (Reason Opt_WarnMissingImportList) + (missingImportListWarn imp_mod_name) + + iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg) + + -- Compiler sanity check: if the import didn't say + -- {-# SOURCE #-} we should not get a hi-boot file + WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) do + + -- Issue a user warning for a redundant {- SOURCE -} import + -- NB that we arrange to read all the ordinary imports before + -- any of the {- SOURCE -} imports. + -- + -- in --make and GHCi, the compilation manager checks for this, + -- and indeed we shouldn't do it here because the existence of + -- the non-boot module depends on the compilation order, which + -- is not deterministic. The hs-boot test can show this up. + dflags <- getDynFlags + warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags)) + (warnRedundantSourceImport imp_mod_name) + when (mod_safe && not (safeImportsOn dflags)) $ + addErr (text "safe import can't be used as Safe Haskell isn't on!" + $+$ ptext (sLit $ "please enable Safe Haskell through either " + ++ "Safe, Trustworthy or Unsafe")) + + let + qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name + imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, + is_dloc = loc, is_as = qual_mod_name } + + -- filter the imports according to the import declaration + (new_imp_details, gres) <- filterImports iface imp_spec imp_details + + -- for certain error messages, we’d like to know what could be imported + -- here, if everything were imported + potential_gres <- mkGlobalRdrEnv . snd <$> filterImports iface imp_spec Nothing + + let gbl_env = mkGlobalRdrEnv gres + + is_hiding | Just (True,_) <- imp_details = True + | otherwise = False + + -- should the import be safe? + mod_safe' = mod_safe + || (not implicit && safeDirectImpsReq dflags) + || (implicit && safeImplicitImpsReq dflags) + + let imv = ImportedModsVal + { imv_name = qual_mod_name + , imv_span = loc + , imv_is_safe = mod_safe' + , imv_is_hiding = is_hiding + , imv_all_exports = potential_gres + , imv_qualified = qual_only + } + imports = calculateAvails dflags iface mod_safe' want_boot (ImportedByUser imv) + + -- Complain if we import a deprecated module + whenWOptM Opt_WarnWarningsDeprecations ( + case (mi_warns iface) of + WarnAll txt -> addWarn (Reason Opt_WarnWarningsDeprecations) + (moduleWarn imp_mod_name txt) + _ -> return () + ) + + let new_imp_decl = L loc (decl { ideclExt = noExtField, ideclSafe = mod_safe' + , ideclHiding = new_imp_details }) + + return (new_imp_decl, gbl_env, imports, mi_hpc iface) +rnImportDecl _ (L _ (XImportDecl nec)) = noExtCon nec + +-- | Calculate the 'ImportAvails' induced by an import of a particular +-- interface, but without 'imp_mods'. +calculateAvails :: DynFlags + -> ModIface + -> IsSafeImport + -> IsBootInterface + -> ImportedBy + -> ImportAvails +calculateAvails dflags iface mod_safe' want_boot imported_by = + let imp_mod = mi_module iface + imp_sem_mod= mi_semantic_module iface + orph_iface = mi_orphan (mi_final_exts iface) + has_finsts = mi_finsts (mi_final_exts iface) + deps = mi_deps iface + trust = getSafeMode $ mi_trust iface + trust_pkg = mi_trust_pkg iface + + -- If the module exports anything defined in this module, just + -- ignore it. Reason: otherwise it looks as if there are two + -- local definition sites for the thing, and an error gets + -- reported. Easiest thing is just to filter them out up + -- front. This situation only arises if a module imports + -- itself, or another module that imported it. (Necessarily, + -- this invoves a loop.) + -- + -- We do this *after* filterImports, so that if you say + -- module A where + -- import B( AType ) + -- type AType = ... + -- + -- module B( AType ) where + -- import {-# SOURCE #-} A( AType ) + -- + -- then you won't get a 'B does not export AType' message. + + + -- Compute new transitive dependencies + -- + -- 'dep_orphs' and 'dep_finsts' do NOT include the imported module + -- itself, but we DO need to include this module in 'imp_orphs' and + -- 'imp_finsts' if it defines an orphan or instance family; thus the + -- orph_iface/has_iface tests. + + orphans | orph_iface = ASSERT2( not (imp_sem_mod `elem` dep_orphs deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) ) + imp_sem_mod : dep_orphs deps + | otherwise = dep_orphs deps + + finsts | has_finsts = ASSERT2( not (imp_sem_mod `elem` dep_finsts deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) ) + imp_sem_mod : dep_finsts deps + | otherwise = dep_finsts deps + + pkg = moduleUnitId (mi_module iface) + ipkg = toInstalledUnitId pkg + + -- Does this import mean we now require our own pkg + -- to be trusted? See Note [Trust Own Package] + ptrust = trust == Sf_Trustworthy || trust_pkg + + (dependent_mods, dependent_pkgs, pkg_trust_req) + | pkg == thisPackage dflags = + -- Imported module is from the home package + -- Take its dependent modules and add imp_mod itself + -- Take its dependent packages unchanged + -- + -- NB: (dep_mods deps) might include a hi-boot file + -- for the module being compiled, CM. Do *not* filter + -- this out (as we used to), because when we've + -- finished dealing with the direct imports we want to + -- know if any of them depended on CM.hi-boot, in + -- which case we should do the hi-boot consistency + -- check. See GHC.Iface.Load.loadHiBootInterface + ((moduleName imp_mod,want_boot):dep_mods deps,dep_pkgs deps,ptrust) + + | otherwise = + -- Imported module is from another package + -- Dump the dependent modules + -- Add the package imp_mod comes from to the dependent packages + ASSERT2( not (ipkg `elem` (map fst $ dep_pkgs deps)) + , ppr ipkg <+> ppr (dep_pkgs deps) ) + ([], (ipkg, False) : dep_pkgs deps, False) + + in ImportAvails { + imp_mods = unitModuleEnv (mi_module iface) [imported_by], + imp_orphs = orphans, + imp_finsts = finsts, + imp_dep_mods = mkModDeps dependent_mods, + imp_dep_pkgs = S.fromList . map fst $ dependent_pkgs, + -- Add in the imported modules trusted package + -- requirements. ONLY do this though if we import the + -- module as a safe import. + -- See Note [Tracking Trust Transitively] + -- and Note [Trust Transitive Property] + imp_trust_pkgs = if mod_safe' + then S.fromList . map fst $ filter snd dependent_pkgs + else S.empty, + -- Do we require our own pkg to be trusted? + -- See Note [Trust Own Package] + imp_trust_own_pkg = pkg_trust_req + } + + +warnRedundantSourceImport :: ModuleName -> SDoc +warnRedundantSourceImport mod_name + = text "Unnecessary {-# SOURCE #-} in the import of module" + <+> quotes (ppr mod_name) + +{- +************************************************************************ +* * +\subsection{importsFromLocalDecls} +* * +************************************************************************ + +From the top-level declarations of this module produce + * the lexical environment + * the ImportAvails +created by its bindings. + +Note [Top-level Names in Template Haskell decl quotes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also: Note [Interactively-bound Ids in GHCi] in HscTypes + Note [Looking up Exact RdrNames] in GHC.Rename.Env + +Consider a Template Haskell declaration quotation like this: + module M where + f x = h [d| f = 3 |] +When renaming the declarations inside [d| ...|], we treat the +top level binders specially in two ways + +1. We give them an Internal Name, not (as usual) an External one. + This is done by GHC.Rename.Env.newTopSrcBinder. + +2. We make them *shadow* the outer bindings. + See Note [GlobalRdrEnv shadowing] + +3. We find out whether we are inside a [d| ... |] by testing the TH + stage. This is a slight hack, because the stage field was really + meant for the type checker, and here we are not interested in the + fields of Brack, hence the error thunks in thRnBrack. +-} + +extendGlobalRdrEnvRn :: [AvailInfo] + -> MiniFixityEnv + -> RnM (TcGblEnv, TcLclEnv) +-- Updates both the GlobalRdrEnv and the FixityEnv +-- We return a new TcLclEnv only because we might have to +-- delete some bindings from it; +-- see Note [Top-level Names in Template Haskell decl quotes] + +extendGlobalRdrEnvRn avails new_fixities + = do { (gbl_env, lcl_env) <- getEnvs + ; stage <- getStage + ; isGHCi <- getIsGHCi + ; let rdr_env = tcg_rdr_env gbl_env + fix_env = tcg_fix_env gbl_env + th_bndrs = tcl_th_bndrs lcl_env + th_lvl = thLevel stage + + -- Delete new_occs from global and local envs + -- If we are in a TemplateHaskell decl bracket, + -- we are going to shadow them + -- See Note [GlobalRdrEnv shadowing] + inBracket = isBrackStage stage + + lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs } + -- See Note [GlobalRdrEnv shadowing] + + lcl_env2 | inBracket = lcl_env_TH + | otherwise = lcl_env + + -- Deal with shadowing: see Note [GlobalRdrEnv shadowing] + want_shadowing = isGHCi || inBracket + rdr_env1 | want_shadowing = shadowNames rdr_env new_names + | otherwise = rdr_env + + lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs + [ (n, (TopLevel, th_lvl)) + | n <- new_names ] } + + ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres + + ; let fix_env' = foldl' extend_fix_env fix_env new_gres + gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' } + + ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2) + ; return (gbl_env', lcl_env3) } + where + new_names = concatMap availNames avails + new_occs = map nameOccName new_names + + -- If there is a fixity decl for the gre, add it to the fixity env + extend_fix_env fix_env gre + | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ) + = extendNameEnv fix_env name (FixItem occ fi) + | otherwise + = fix_env + where + name = gre_name gre + occ = greOccName gre + + new_gres :: [GlobalRdrElt] -- New LocalDef GREs, derived from avails + new_gres = concatMap localGREsFromAvail avails + + add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv + -- Extend the GlobalRdrEnv with a LocalDef GRE + -- If there is already a LocalDef GRE with the same OccName, + -- report an error and discard the new GRE + -- This establishes INVARIANT 1 of GlobalRdrEnvs + add_gre env gre + | not (null dups) -- Same OccName defined twice + = do { addDupDeclErr (gre : dups); return env } + + | otherwise + = return (extendGlobalRdrEnv env gre) + where + name = gre_name gre + occ = nameOccName name + dups = filter isLocalGRE (lookupGlobalRdrEnv env occ) + + +{- ********************************************************************* +* * + getLocalDeclBindersd@ returns the names for an HsDecl + It's used for source code. + + *** See Note [The Naming story] in GHC.Hs.Decls **** +* * +********************************************************************* -} + +getLocalNonValBinders :: MiniFixityEnv -> HsGroup GhcPs + -> RnM ((TcGblEnv, TcLclEnv), NameSet) +-- Get all the top-level binders bound the group *except* +-- for value bindings, which are treated separately +-- Specifically we return AvailInfo for +-- * type decls (incl constructors and record selectors) +-- * class decls (including class ops) +-- * associated types +-- * foreign imports +-- * value signatures (in hs-boot files only) + +getLocalNonValBinders fixity_env + (HsGroup { hs_valds = binds, + hs_tyclds = tycl_decls, + hs_fords = foreign_decls }) + = do { -- Process all type/class decls *except* family instances + ; let inst_decls = tycl_decls >>= group_instds + ; overload_ok <- xoptM LangExt.DuplicateRecordFields + ; (tc_avails, tc_fldss) + <- fmap unzip $ mapM (new_tc overload_ok) + (tyClGroupTyClDecls tycl_decls) + ; traceRn "getLocalNonValBinders 1" (ppr tc_avails) + ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env + ; setEnvs envs $ do { + -- Bring these things into scope first + -- See Note [Looking up family names in family instances] + + -- Process all family instances + -- to bring new data constructors into scope + ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc overload_ok) + inst_decls + + -- Finish off with value binders: + -- foreign decls and pattern synonyms for an ordinary module + -- type sigs in case of a hs-boot file only + ; is_boot <- tcIsHsBootOrSig + ; let val_bndrs | is_boot = hs_boot_sig_bndrs + | otherwise = for_hs_bndrs + ; val_avails <- mapM new_simple val_bndrs + + ; let avails = concat nti_availss ++ val_avails + new_bndrs = availsToNameSetWithSelectors avails `unionNameSet` + availsToNameSetWithSelectors tc_avails + flds = concat nti_fldss ++ concat tc_fldss + ; traceRn "getLocalNonValBinders 2" (ppr avails) + ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env + + -- Extend tcg_field_env with new fields (this used to be the + -- work of extendRecordFieldEnv) + ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds + envs = (tcg_env { tcg_field_env = field_env }, tcl_env) + + ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env]) + ; return (envs, new_bndrs) } } + where + ValBinds _ _val_binds val_sigs = binds + + for_hs_bndrs :: [Located RdrName] + for_hs_bndrs = hsForeignDeclsBinders foreign_decls + + -- In a hs-boot file, the value binders come from the + -- *signatures*, and there should be no foreign binders + hs_boot_sig_bndrs = [ L decl_loc (unLoc n) + | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns] + + -- the SrcSpan attached to the input should be the span of the + -- declaration, not just the name + new_simple :: Located RdrName -> RnM AvailInfo + new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name + ; return (avail nm) } + + new_tc :: Bool -> LTyClDecl GhcPs + -> RnM (AvailInfo, [(Name, [FieldLabel])]) + new_tc overload_ok tc_decl -- NOT for type/data instances + = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl + ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs + ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds + ; let fld_env = case unLoc tc_decl of + DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds' + _ -> [] + ; return (AvailTC main_name names flds', fld_env) } + + + -- Calculate the mapping from constructor names to fields, which + -- will go in tcg_field_env. It's convenient to do this here where + -- we are working with a single datatype definition. + mk_fld_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel] + -> [(Name, [FieldLabel])] + mk_fld_env d names flds = concatMap find_con_flds (dd_cons d) + where + find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr + , con_args = RecCon cdflds })) + = [( find_con_name rdr + , concatMap find_con_decl_flds (unLoc cdflds) )] + find_con_flds (L _ (ConDeclGADT { con_names = rdrs + , con_args = RecCon flds })) + = [ ( find_con_name rdr + , concatMap find_con_decl_flds (unLoc flds)) + | L _ rdr <- rdrs ] + + find_con_flds _ = [] + + find_con_name rdr + = expectJust "getLocalNonValBinders/find_con_name" $ + find (\ n -> nameOccName n == rdrNameOcc rdr) names + find_con_decl_flds (L _ x) + = map find_con_decl_fld (cd_fld_names x) + + find_con_decl_fld (L _ (FieldOcc _ (L _ rdr))) + = expectJust "getLocalNonValBinders/find_con_decl_fld" $ + find (\ fl -> flLabel fl == lbl) flds + where lbl = occNameFS (rdrNameOcc rdr) + find_con_decl_fld (L _ (XFieldOcc nec)) = noExtCon nec + + new_assoc :: Bool -> LInstDecl GhcPs + -> RnM ([AvailInfo], [(Name, [FieldLabel])]) + new_assoc _ (L _ (TyFamInstD {})) = return ([], []) + -- type instances don't bind new names + + new_assoc overload_ok (L _ (DataFamInstD _ d)) + = do { (avail, flds) <- new_di overload_ok Nothing d + ; return ([avail], flds) } + new_assoc overload_ok (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty + , cid_datafam_insts = adts }))) + = do -- First, attempt to grab the name of the class from the instance. + -- This step could fail if the instance is not headed by a class, + -- such as in the following examples: + -- + -- (1) The class is headed by a bang pattern, such as in + -- `instance !Show Int` (#3811c) + -- (2) The class is headed by a type variable, such as in + -- `instance c` (#16385) + -- + -- If looking up the class name fails, then mb_cls_nm will + -- be Nothing. + mb_cls_nm <- runMaybeT $ do + -- See (1) above + L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty + -- See (2) above + MaybeT $ setSrcSpan loc $ lookupGlobalOccRn_maybe cls_rdr + -- Assuming the previous step succeeded, process any associated data + -- family instances. If the previous step failed, bail out. + case mb_cls_nm of + Nothing -> pure ([], []) + Just cls_nm -> do + (avails, fldss) + <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts + pure (avails, concat fldss) + new_assoc _ (L _ (ClsInstD _ (XClsInstDecl nec))) = noExtCon nec + new_assoc _ (L _ (XInstDecl nec)) = noExtCon nec + + new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs + -> RnM (AvailInfo, [(Name, [FieldLabel])]) + new_di overload_ok mb_cls dfid@(DataFamInstDecl { dfid_eqn = + HsIB { hsib_body = ti_decl }}) + = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl) + ; let (bndrs, flds) = hsDataFamInstBinders dfid + ; sub_names <- mapM newTopSrcBinder bndrs + ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds + ; let avail = AvailTC (unLoc main_name) sub_names flds' + -- main_name is not bound here! + fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds' + ; return (avail, fld_env) } + new_di _ _ (DataFamInstDecl (XHsImplicitBndrs nec)) = noExtCon nec + + new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs + -> RnM (AvailInfo, [(Name, [FieldLabel])]) + new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d +getLocalNonValBinders _ (XHsGroup nec) = noExtCon nec + +newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel +newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!" +newRecordSelector _ _ (L _ (XFieldOcc nec)) = noExtCon nec +newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld))) + = do { selName <- newTopSrcBinder $ L loc $ field + ; return $ qualFieldLbl { flSelector = selName } } + where + fieldOccName = occNameFS $ rdrNameOcc fld + qualFieldLbl = mkFieldLabelOccs fieldOccName (nameOccName dc) overload_ok + field | isExact fld = fld + -- use an Exact RdrName as is to preserve the bindings + -- of an already renamer-resolved field and its use + -- sites. This is needed to correctly support record + -- selectors in Template Haskell. See Note [Binders in + -- Template Haskell] in Convert.hs and Note [Looking up + -- Exact RdrNames] in GHC.Rename.Env. + | otherwise = mkRdrUnqual (flSelector qualFieldLbl) + +{- +Note [Looking up family names in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + module M where + type family T a :: * + type instance M.T Int = Bool + +We might think that we can simply use 'lookupOccRn' when processing the type +instance to look up 'M.T'. Alas, we can't! The type family declaration is in +the *same* HsGroup as the type instance declaration. Hence, as we are +currently collecting the binders declared in that HsGroup, these binders will +not have been added to the global environment yet. + +Solution is simple: process the type family declarations first, extend +the environment, and then process the type instances. + + +************************************************************************ +* * +\subsection{Filtering imports} +* * +************************************************************************ + +@filterImports@ takes the @ExportEnv@ telling what the imported module makes +available, and filters it through the import spec (if any). + +Note [Dealing with imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For import M( ies ), we take the mi_exports of M, and make + imp_occ_env :: OccEnv (Name, AvailInfo, Maybe Name) +One entry for each Name that M exports; the AvailInfo is the +AvailInfo exported from M that exports that Name. + +The situation is made more complicated by associated types. E.g. + module M where + class C a where { data T a } + instance C Int where { data T Int = T1 | T2 } + instance C Bool where { data T Int = T3 } +Then M's export_avails are (recall the AvailTC invariant from Avails.hs) + C(C,T), T(T,T1,T2,T3) +Notice that T appears *twice*, once as a child and once as a parent. From +this list we construct a raw list including + T -> (T, T( T1, T2, T3 ), Nothing) + T -> (C, C( C, T ), Nothing) +and we combine these (in function 'combine' in 'imp_occ_env' in +'filterImports') to get + T -> (T, T(T,T1,T2,T3), Just C) + +So the overall imp_occ_env is + C -> (C, C(C,T), Nothing) + T -> (T, T(T,T1,T2,T3), Just C) + T1 -> (T1, T(T,T1,T2,T3), Nothing) -- similarly T2,T3 + +If we say + import M( T(T1,T2) ) +then we get *two* Avails: C(T), T(T1,T2) + +Note that the imp_occ_env will have entries for data constructors too, +although we never look up data constructors. +-} + +filterImports + :: ModIface + -> ImpDeclSpec -- The span for the entire import decl + -> Maybe (Bool, Located [LIE GhcPs]) -- Import spec; True => hiding + -> RnM (Maybe (Bool, Located [LIE GhcRn]), -- Import spec w/ Names + [GlobalRdrElt]) -- Same again, but in GRE form +filterImports iface decl_spec Nothing + = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface)) + where + imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } + + +filterImports iface decl_spec (Just (want_hiding, L l import_items)) + = do -- check for errors, convert RdrNames to Names + items1 <- mapM lookup_lie import_items + + let items2 :: [(LIE GhcRn, AvailInfo)] + items2 = concat items1 + -- NB the AvailInfo may have duplicates, and several items + -- for the same parent; e.g N(x) and N(y) + + names = availsToNameSetWithSelectors (map snd items2) + keep n = not (n `elemNameSet` names) + pruned_avails = filterAvails keep all_avails + hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } + + gres | want_hiding = gresFromAvails (Just hiding_spec) pruned_avails + | otherwise = concatMap (gresFromIE decl_spec) items2 + + return (Just (want_hiding, L l (map fst items2)), gres) + where + all_avails = mi_exports iface + + -- See Note [Dealing with imports] + imp_occ_env :: OccEnv (Name, -- the name + AvailInfo, -- the export item providing the name + Maybe Name) -- the parent of associated types + imp_occ_env = mkOccEnv_C combine [ (occ, (n, a, Nothing)) + | a <- all_avails + , (n, occ) <- availNamesWithOccs a] + where + -- See Note [Dealing with imports] + -- 'combine' is only called for associated data types which appear + -- twice in the all_avails. In the example, we combine + -- T(T,T1,T2,T3) and C(C,T) to give (T, T(T,T1,T2,T3), Just C) + -- NB: the AvailTC can have fields as well as data constructors (#12127) + combine (name1, a1@(AvailTC p1 _ _), mp1) + (name2, a2@(AvailTC p2 _ _), mp2) + = ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2 + , ppr name1 <+> ppr name2 <+> ppr mp1 <+> ppr mp2 ) + if p1 == name1 then (name1, a1, Just p2) + else (name1, a2, Just p1) + combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y) + + lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name) + lookup_name ie rdr + | isQual rdr = failLookupWith (QualImportError rdr) + | Just succ <- mb_success = return succ + | otherwise = failLookupWith (BadImport ie) + where + mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr) + + lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)] + lookup_lie (L loc ieRdr) + = do (stuff, warns) <- setSrcSpan loc $ + liftM (fromMaybe ([],[])) $ + run_lookup (lookup_ie ieRdr) + mapM_ emit_warning warns + return [ (L loc ie, avail) | (ie,avail) <- stuff ] + where + -- Warn when importing T(..) if T was exported abstractly + emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $ + addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n) + emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $ + addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr) + emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $ + addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie)) + + run_lookup :: IELookupM a -> TcRn (Maybe a) + run_lookup m = case m of + Failed err -> addErr (lookup_err_msg err) >> return Nothing + Succeeded a -> return (Just a) + + lookup_err_msg err = case err of + BadImport ie -> badImportItemErr iface decl_spec ie all_avails + IllegalImport -> illegalImportItemErr + QualImportError rdr -> qualImportItemErr rdr + + -- For each import item, we convert its RdrNames to Names, + -- and at the same time construct an AvailInfo corresponding + -- to what is actually imported by this item. + -- Returns Nothing on error. + -- We return a list here, because in the case of an import + -- item like C, if we are hiding, then C refers to *both* a + -- type/class and a data constructor. Moreover, when we import + -- data constructors of an associated family, we need separate + -- AvailInfos for the data constructors and the family (as they have + -- different parents). See Note [Dealing with imports] + lookup_ie :: IE GhcPs + -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning]) + lookup_ie ie = handle_bad_import $ do + case ie of + IEVar _ (L l n) -> do + (name, avail, _) <- lookup_name ie $ ieWrappedName n + return ([(IEVar noExtField (L l (replaceWrappedName n name)), + trimAvail avail name)], []) + + IEThingAll _ (L l tc) -> do + (name, avail, mb_parent) <- lookup_name ie $ ieWrappedName tc + let warns = case avail of + Avail {} -- e.g. f(..) + -> [DodgyImport $ ieWrappedName tc] + + AvailTC _ subs fs + | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym + -> [DodgyImport $ ieWrappedName tc] + + | not (is_qual decl_spec) -- e.g. import M( T(..) ) + -> [MissingImportList] + + | otherwise + -> [] + + renamed_ie = IEThingAll noExtField (L l (replaceWrappedName tc name)) + sub_avails = case avail of + Avail {} -> [] + AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)] + case mb_parent of + Nothing -> return ([(renamed_ie, avail)], warns) + -- non-associated ty/cls + Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns) + -- associated type + + IEThingAbs _ (L l tc') + | want_hiding -- hiding ( C ) + -- Here the 'C' can be a data constructor + -- *or* a type/class, or even both + -> let tc = ieWrappedName tc' + tc_name = lookup_name ie tc + dc_name = lookup_name ie (setRdrNameSpace tc srcDataName) + in + case catIELookupM [ tc_name, dc_name ] of + [] -> failLookupWith (BadImport ie) + names -> return ([mkIEThingAbs tc' l name | name <- names], []) + | otherwise + -> do nameAvail <- lookup_name ie (ieWrappedName tc') + return ([mkIEThingAbs tc' l nameAvail] + , []) + + IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs -> + ASSERT2(null rdr_fs, ppr rdr_fs) do + (name, avail, mb_parent) + <- lookup_name (IEThingAbs noExtField ltc) (ieWrappedName rdr_tc) + + let (ns,subflds) = case avail of + AvailTC _ ns' subflds' -> (ns',subflds') + Avail _ -> panic "filterImports" + + -- Look up the children in the sub-names of the parent + let subnames = case ns of -- The tc is first in ns, + [] -> [] -- if it is there at all + -- See the AvailTC Invariant in Avail.hs + (n1:ns1) | n1 == name -> ns1 + | otherwise -> ns + case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of + + Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs [])) + -- We are trying to import T( a,b,c,d ), and failed + -- to find 'b' and 'd'. So we make up an import item + -- to report as failing, namely T( b, d ). + -- c.f. #15412 + + Succeeded (childnames, childflds) -> + case mb_parent of + -- non-associated ty/cls + Nothing + -> return ([(IEThingWith noExtField (L l name') wc childnames' + childflds, + AvailTC name (name:map unLoc childnames) (map unLoc childflds))], + []) + where name' = replaceWrappedName rdr_tc name + childnames' = map to_ie_post_rn childnames + -- childnames' = postrn_ies childnames + -- associated ty + Just parent + -> return ([(IEThingWith noExtField (L l name') wc childnames' + childflds, + AvailTC name (map unLoc childnames) (map unLoc childflds)), + (IEThingWith noExtField (L l name') wc childnames' + childflds, + AvailTC parent [name] [])], + []) + where name' = replaceWrappedName rdr_tc name + childnames' = map to_ie_post_rn childnames + + _other -> failLookupWith IllegalImport + -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed + -- all errors. + + where + mkIEThingAbs tc l (n, av, Nothing ) + = (IEThingAbs noExtField (L l (replaceWrappedName tc n)), trimAvail av n) + mkIEThingAbs tc l (n, _, Just parent) + = (IEThingAbs noExtField (L l (replaceWrappedName tc n)) + , AvailTC parent [n] []) + + handle_bad_import m = catchIELookup m $ \err -> case err of + BadImport ie | want_hiding -> return ([], [BadImportW ie]) + _ -> failLookupWith err + +type IELookupM = MaybeErr IELookupError + +data IELookupWarning + = BadImportW (IE GhcPs) + | MissingImportList + | DodgyImport RdrName + -- NB. use the RdrName for reporting a "dodgy" import + +data IELookupError + = QualImportError RdrName + | BadImport (IE GhcPs) + | IllegalImport + +failLookupWith :: IELookupError -> IELookupM a +failLookupWith err = Failed err + +catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a +catchIELookup m h = case m of + Succeeded r -> return r + Failed err -> h err + +catIELookupM :: [IELookupM a] -> [a] +catIELookupM ms = [ a | Succeeded a <- ms ] + +{- +************************************************************************ +* * +\subsection{Import/Export Utils} +* * +************************************************************************ +-} + +-- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's. +gresFromIE :: ImpDeclSpec -> (LIE GhcRn, AvailInfo) -> [GlobalRdrElt] +gresFromIE decl_spec (L loc ie, avail) + = gresFromAvail prov_fn avail + where + is_explicit = case ie of + IEThingAll _ name -> \n -> n == lieWrappedName name + _ -> \_ -> True + prov_fn name + = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec }) + where + item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc } + + +{- +Note [Children for duplicate record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the module + + {-# LANGUAGE DuplicateRecordFields #-} + module M (F(foo, MkFInt, MkFBool)) where + data family F a + data instance F Int = MkFInt { foo :: Int } + data instance F Bool = MkFBool { foo :: Bool } + +The `foo` in the export list refers to *both* selectors! For this +reason, lookupChildren builds an environment that maps the FastString +to a list of items, rather than a single item. +-} + +mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt] +mkChildEnv gres = foldr add emptyNameEnv gres + where + add gre env = case gre_par gre of + FldParent p _ -> extendNameEnv_Acc (:) singleton env p gre + ParentIs p -> extendNameEnv_Acc (:) singleton env p gre + NoParent -> env + +findChildren :: NameEnv [a] -> Name -> [a] +findChildren env n = lookupNameEnv env n `orElse` [] + +lookupChildren :: [Either Name FieldLabel] -> [LIEWrappedName RdrName] + -> MaybeErr [LIEWrappedName RdrName] -- The ones for which the lookup failed + ([Located Name], [Located FieldLabel]) +-- (lookupChildren all_kids rdr_items) maps each rdr_item to its +-- corresponding Name all_kids, if the former exists +-- The matching is done by FastString, not OccName, so that +-- Cls( meth, AssocTy ) +-- will correctly find AssocTy among the all_kids of Cls, even though +-- the RdrName for AssocTy may have a (bogus) DataName namespace +-- (Really the rdr_items should be FastStrings in the first place.) +lookupChildren all_kids rdr_items + | null fails + = Succeeded (fmap concat (partitionEithers oks)) + -- This 'fmap concat' trickily applies concat to the /second/ component + -- of the pair, whose type is ([Located Name], [[Located FieldLabel]]) + | otherwise + = Failed fails + where + mb_xs = map doOne rdr_items + fails = [ bad_rdr | Failed bad_rdr <- mb_xs ] + oks = [ ok | Succeeded ok <- mb_xs ] + oks :: [Either (Located Name) [Located FieldLabel]] + + doOne item@(L l r) + = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of + Just [Left n] -> Succeeded (Left (L l n)) + Just rs | all isRight rs -> Succeeded (Right (map (L l) (rights rs))) + _ -> Failed item + + -- See Note [Children for duplicate record fields] + kid_env = extendFsEnvList_C (++) emptyFsEnv + [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids] + + + +------------------------------- + +{- +********************************************************* +* * +\subsection{Unused names} +* * +********************************************************* +-} + +reportUnusedNames :: TcGblEnv -> RnM () +reportUnusedNames gbl_env + = do { keep <- readTcRef (tcg_keep gbl_env) + ; traceRn "RUN" (ppr (tcg_dus gbl_env)) + ; warnUnusedImportDecls gbl_env + ; warnUnusedTopBinds $ unused_locals keep + ; warnMissingSignatures gbl_env } + where + used_names :: NameSet -> NameSet + used_names keep = findUses (tcg_dus gbl_env) emptyNameSet `unionNameSet` keep + -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used + -- Hence findUses + + -- Collect the defined names from the in-scope environment + defined_names :: [GlobalRdrElt] + defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env) + + kids_env = mkChildEnv defined_names + -- This is done in mkExports too; duplicated work + + gre_is_used :: NameSet -> GlobalRdrElt -> Bool + gre_is_used used_names (GRE {gre_name = name}) + = name `elemNameSet` used_names + || any (\ gre -> gre_name gre `elemNameSet` used_names) (findChildren kids_env name) + -- A use of C implies a use of T, + -- if C was brought into scope by T(..) or T(C) + + -- Filter out the ones that are + -- (a) defined in this module, and + -- (b) not defined by a 'deriving' clause + -- The latter have an Internal Name, so we can filter them out easily + unused_locals :: NameSet -> [GlobalRdrElt] + unused_locals keep = + let -- Note that defined_and_used, defined_but_not_used + -- are both [GRE]; that's why we need defined_and_used + -- rather than just used_names + _defined_and_used, defined_but_not_used :: [GlobalRdrElt] + (_defined_and_used, defined_but_not_used) + = partition (gre_is_used (used_names keep)) defined_names + + in filter is_unused_local defined_but_not_used + is_unused_local :: GlobalRdrElt -> Bool + is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre) + +{- ********************************************************************* +* * + Missing signatures +* * +********************************************************************* -} + +-- | Warn the user about top level binders that lack type signatures. +-- Called /after/ type inference, so that we can report the +-- inferred type of the function +warnMissingSignatures :: TcGblEnv -> RnM () +warnMissingSignatures gbl_env + = do { let exports = availsToNameSet (tcg_exports gbl_env) + sig_ns = tcg_sigs gbl_env + -- We use sig_ns to exclude top-level bindings that are generated by GHC + binds = collectHsBindsBinders $ tcg_binds gbl_env + pat_syns = tcg_patsyns gbl_env + + -- Warn about missing signatures + -- Do this only when we have a type to offer + ; warn_missing_sigs <- woptM Opt_WarnMissingSignatures + ; warn_only_exported <- woptM Opt_WarnMissingExportedSignatures + ; warn_pat_syns <- woptM Opt_WarnMissingPatternSynonymSignatures + + ; let add_sig_warns + | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures + | warn_missing_sigs = add_warns Opt_WarnMissingSignatures + | warn_pat_syns = add_warns Opt_WarnMissingPatternSynonymSignatures + | otherwise = return () + + add_warns flag + = when warn_pat_syns + (mapM_ add_pat_syn_warn pat_syns) >> + when (warn_missing_sigs || warn_only_exported) + (mapM_ add_bind_warn binds) + where + add_pat_syn_warn p + = add_warn name $ + hang (text "Pattern synonym with no type signature:") + 2 (text "pattern" <+> pprPrefixName name <+> dcolon <+> pp_ty) + where + name = patSynName p + pp_ty = pprPatSynType p + + add_bind_warn :: Id -> IOEnv (Env TcGblEnv TcLclEnv) () + add_bind_warn id + = do { env <- tcInitTidyEnv -- Why not use emptyTidyEnv? + ; let name = idName id + (_, ty) = tidyOpenType env (idType id) + ty_msg = pprSigmaType ty + ; add_warn name $ + hang (text "Top-level binding with no type signature:") + 2 (pprPrefixName name <+> dcolon <+> ty_msg) } + + add_warn name msg + = when (name `elemNameSet` sig_ns && export_check name) + (addWarnAt (Reason flag) (getSrcSpan name) msg) + + export_check name + = not warn_only_exported || name `elemNameSet` exports + + ; add_sig_warns } + + +{- +********************************************************* +* * +\subsection{Unused imports} +* * +********************************************************* + +This code finds which import declarations are unused. The +specification and implementation notes are here: + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/unused-imports + +See also Note [Choosing the best import declaration] in RdrName +-} + +type ImportDeclUsage + = ( LImportDecl GhcRn -- The import declaration + , [GlobalRdrElt] -- What *is* used (normalised) + , [Name] ) -- What is imported but *not* used + +warnUnusedImportDecls :: TcGblEnv -> RnM () +warnUnusedImportDecls gbl_env + = do { uses <- readMutVar (tcg_used_gres gbl_env) + ; let user_imports = filterOut + (ideclImplicit . unLoc) + (tcg_rn_imports gbl_env) + -- This whole function deals only with *user* imports + -- both for warning about unnecessary ones, and for + -- deciding the minimal ones + rdr_env = tcg_rdr_env gbl_env + fld_env = mkFieldEnv rdr_env + + ; let usage :: [ImportDeclUsage] + usage = findImportUsage user_imports uses + + ; traceRn "warnUnusedImportDecls" $ + (vcat [ text "Uses:" <+> ppr uses + , text "Import usage" <+> ppr usage]) + + ; whenWOptM Opt_WarnUnusedImports $ + mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage + + ; whenGOptM Opt_D_dump_minimal_imports $ + printMinimalImports usage } + +findImportUsage :: [LImportDecl GhcRn] + -> [GlobalRdrElt] + -> [ImportDeclUsage] + +findImportUsage imports used_gres + = map unused_decl imports + where + import_usage :: ImportMap + import_usage = mkImportMap used_gres + + unused_decl decl@(L loc (ImportDecl { ideclHiding = imps })) + = (decl, used_gres, nameSetElemsStable unused_imps) + where + used_gres = Map.lookup (srcSpanEnd loc) import_usage + -- srcSpanEnd: see Note [The ImportMap] + `orElse` [] + + used_names = mkNameSet (map gre_name used_gres) + used_parents = mkNameSet (mapMaybe greParent_maybe used_gres) + + unused_imps -- Not trivial; see eg #7454 + = case imps of + Just (False, L _ imp_ies) -> + foldr (add_unused . unLoc) emptyNameSet imp_ies + _other -> emptyNameSet -- No explicit import list => no unused-name list + + add_unused :: IE GhcRn -> NameSet -> NameSet + add_unused (IEVar _ n) acc = add_unused_name (lieWrappedName n) acc + add_unused (IEThingAbs _ n) acc = add_unused_name (lieWrappedName n) acc + add_unused (IEThingAll _ n) acc = add_unused_all (lieWrappedName n) acc + add_unused (IEThingWith _ p wc ns fs) acc = + add_wc_all (add_unused_with pn xs acc) + where pn = lieWrappedName p + xs = map lieWrappedName ns ++ map (flSelector . unLoc) fs + add_wc_all = case wc of + NoIEWildcard -> id + IEWildcard _ -> add_unused_all pn + add_unused _ acc = acc + + add_unused_name n acc + | n `elemNameSet` used_names = acc + | otherwise = acc `extendNameSet` n + add_unused_all n acc + | n `elemNameSet` used_names = acc + | n `elemNameSet` used_parents = acc + | otherwise = acc `extendNameSet` n + add_unused_with p ns acc + | all (`elemNameSet` acc1) ns = add_unused_name p acc1 + | otherwise = acc1 + where + acc1 = foldr add_unused_name acc ns + -- If you use 'signum' from Num, then the user may well have + -- imported Num(signum). We don't want to complain that + -- Num is not itself mentioned. Hence the two cases in add_unused_with. + unused_decl (L _ (XImportDecl nec)) = noExtCon nec + + +{- Note [The ImportMap] +~~~~~~~~~~~~~~~~~~~~~~~ +The ImportMap is a short-lived intermediate data structure records, for +each import declaration, what stuff brought into scope by that +declaration is actually used in the module. + +The SrcLoc is the location of the END of a particular 'import' +declaration. Why *END*? Because we don't want to get confused +by the implicit Prelude import. Consider (#7476) the module + import Foo( foo ) + main = print foo +There is an implicit 'import Prelude(print)', and it gets a SrcSpan +of line 1:1 (just the point, not a span). If we use the *START* of +the SrcSpan to identify the import decl, we'll confuse the implicit +import Prelude with the explicit 'import Foo'. So we use the END. +It's just a cheap hack; we could equally well use the Span too. + +The [GlobalRdrElt] are the things imported from that decl. +-} + +type ImportMap = Map SrcLoc [GlobalRdrElt] -- See [The ImportMap] + -- If loc :-> gres, then + -- 'loc' = the end loc of the bestImport of each GRE in 'gres' + +mkImportMap :: [GlobalRdrElt] -> ImportMap +-- For each of a list of used GREs, find all the import decls that brought +-- it into scope; choose one of them (bestImport), and record +-- the RdrName in that import decl's entry in the ImportMap +mkImportMap gres + = foldr add_one Map.empty gres + where + add_one gre@(GRE { gre_imp = imp_specs }) imp_map + = Map.insertWith add decl_loc [gre] imp_map + where + best_imp_spec = bestImport imp_specs + decl_loc = srcSpanEnd (is_dloc (is_decl best_imp_spec)) + -- For srcSpanEnd see Note [The ImportMap] + add _ gres = gre : gres + +warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Name) + -> ImportDeclUsage -> RnM () +warnUnusedImport flag fld_env (L loc decl, used, unused) + + -- Do not warn for 'import M()' + | Just (False,L _ []) <- ideclHiding decl + = return () + + -- Note [Do not warn about Prelude hiding] + | Just (True, L _ hides) <- ideclHiding decl + , not (null hides) + , pRELUDE_NAME == unLoc (ideclName decl) + = return () + + -- Nothing used; drop entire declaration + | null used + = addWarnAt (Reason flag) loc msg1 + + -- Everything imported is used; nop + | null unused + = return () + + -- Some imports are unused + | otherwise + = addWarnAt (Reason flag) loc msg2 + + where + msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant + , nest 2 (text "except perhaps to import instances from" + <+> quotes pp_mod) + , text "To import instances alone, use:" + <+> text "import" <+> pp_mod <> parens Outputable.empty ] + msg2 = sep [ pp_herald <+> quotes sort_unused + , text "from module" <+> quotes pp_mod <+> is_redundant] + pp_herald = text "The" <+> pp_qual <+> text "import of" + pp_qual + | isImportDeclQualified (ideclQualified decl)= text "qualified" + | otherwise = Outputable.empty + pp_mod = ppr (unLoc (ideclName decl)) + is_redundant = text "is redundant" + + -- In warning message, pretty-print identifiers unqualified unconditionally + -- to improve the consistent for ambiguous/unambiguous identifiers. + -- See trac#14881. + ppr_possible_field n = case lookupNameEnv fld_env n of + Just (fld, p) -> pprNameUnqualified p <> parens (ppr fld) + Nothing -> pprNameUnqualified n + + -- Print unused names in a deterministic (lexicographic) order + sort_unused :: SDoc + sort_unused = pprWithCommas ppr_possible_field $ + sortBy (comparing nameOccName) unused + +{- +Note [Do not warn about Prelude hiding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do not warn about + import Prelude hiding( x, y ) +because even if nothing else from Prelude is used, it may be essential to hide +x,y to avoid name-shadowing warnings. Example (#9061) + import Prelude hiding( log ) + f x = log where log = () + + + +Note [Printing minimal imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To print the minimal imports we walk over the user-supplied import +decls, and simply trim their import lists. NB that + + * We do *not* change the 'qualified' or 'as' parts! + + * We do not disard a decl altogether; we might need instances + from it. Instead we just trim to an empty import list +-} + +getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn] +getMinimalImports = mapM mk_minimal + where + mk_minimal (L l decl, used_gres, unused) + | null unused + , Just (False, _) <- ideclHiding decl + = return (L l decl) + | otherwise + = do { let ImportDecl { ideclName = L _ mod_name + , ideclSource = is_boot + , ideclPkgQual = mb_pkg } = decl + ; iface <- loadSrcInterface doc mod_name is_boot (fmap sl_fs mb_pkg) + ; let used_avails = gresToAvailInfo used_gres + lies = map (L l) (concatMap (to_ie iface) used_avails) + ; return (L l (decl { ideclHiding = Just (False, L l lies) })) } + where + doc = text "Compute minimal imports for" <+> ppr decl + + to_ie :: ModIface -> AvailInfo -> [IE GhcRn] + -- The main trick here is that if we're importing all the constructors + -- we want to say "T(..)", but if we're importing only a subset we want + -- to say "T(A,B,C)". So we have to find out what the module exports. + to_ie _ (Avail n) + = [IEVar noExtField (to_ie_post_rn $ noLoc n)] + to_ie _ (AvailTC n [m] []) + | n==m = [IEThingAbs noExtField (to_ie_post_rn $ noLoc n)] + to_ie iface (AvailTC n ns fs) + = case [(xs,gs) | AvailTC x xs gs <- mi_exports iface + , x == n + , x `elem` xs -- Note [Partial export] + ] of + [xs] | all_used xs -> [IEThingAll noExtField (to_ie_post_rn $ noLoc n)] + | otherwise -> + [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard + (map (to_ie_post_rn . noLoc) (filter (/= n) ns)) + (map noLoc fs)] + -- Note [Overloaded field import] + _other | all_non_overloaded fs + -> map (IEVar noExtField . to_ie_post_rn_var . noLoc) $ ns + ++ map flSelector fs + | otherwise -> + [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard + (map (to_ie_post_rn . noLoc) (filter (/= n) ns)) + (map noLoc fs)] + where + + fld_lbls = map flLabel fs + + all_used (avail_occs, avail_flds) + = all (`elem` ns) avail_occs + && all (`elem` fld_lbls) (map flLabel avail_flds) + + all_non_overloaded = all (not . flIsOverloaded) + +printMinimalImports :: [ImportDeclUsage] -> RnM () +-- See Note [Printing minimal imports] +printMinimalImports imports_w_usage + = do { imports' <- getMinimalImports imports_w_usage + ; this_mod <- getModule + ; dflags <- getDynFlags + ; liftIO $ + do { h <- openFile (mkFilename dflags this_mod) WriteMode + ; printForUser dflags h neverQualify (vcat (map ppr imports')) } + -- The neverQualify is important. We are printing Names + -- but they are in the context of an 'import' decl, and + -- we never qualify things inside there + -- E.g. import Blag( f, b ) + -- not import Blag( Blag.f, Blag.g )! + } + where + mkFilename dflags this_mod + | Just d <- dumpDir dflags = d </> basefn + | otherwise = basefn + where + basefn = moduleNameString (moduleName this_mod) ++ ".imports" + + +to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name +to_ie_post_rn_var (L l n) + | isDataOcc $ occName n = L l (IEPattern (L l n)) + | otherwise = L l (IEName (L l n)) + + +to_ie_post_rn :: (HasOccName name) => Located name -> LIEWrappedName name +to_ie_post_rn (L l n) + | isTcOcc occ && isSymOcc occ = L l (IEType (L l n)) + | otherwise = L l (IEName (L l n)) + where occ = occName n + +{- +Note [Partial export] +~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + module A( op ) where + class C a where + op :: a -> a + + module B where + import A + f = ..op... + +Then the minimal import for module B is + import A( op ) +not + import A( C( op ) ) +which we would usually generate if C was exported from B. Hence +the (x `elem` xs) test when deciding what to generate. + + +Note [Overloaded field import] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On the other hand, if we have + + {-# LANGUAGE DuplicateRecordFields #-} + module A where + data T = MkT { foo :: Int } + + module B where + import A + f = ...foo... + +then the minimal import for module B must be + import A ( T(foo) ) +because when DuplicateRecordFields is enabled, field selectors are +not in scope without their enclosing datatype. + + +************************************************************************ +* * +\subsection{Errors} +* * +************************************************************************ +-} + +qualImportItemErr :: RdrName -> SDoc +qualImportItemErr rdr + = hang (text "Illegal qualified name in import item:") + 2 (ppr rdr) + +badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc +badImportItemErrStd iface decl_spec ie + = sep [text "Module", quotes (ppr (is_mod decl_spec)), source_import, + text "does not export", quotes (ppr ie)] + where + source_import | mi_boot iface = text "(hi-boot interface)" + | otherwise = Outputable.empty + +badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE GhcPs + -> SDoc +badImportItemErrDataCon dataType_occ iface decl_spec ie + = vcat [ text "In module" + <+> quotes (ppr (is_mod decl_spec)) + <+> source_import <> colon + , nest 2 $ quotes datacon + <+> text "is a data constructor of" + <+> quotes dataType + , text "To import it use" + , nest 2 $ text "import" + <+> ppr (is_mod decl_spec) + <> parens_sp (dataType <> parens_sp datacon) + , text "or" + , nest 2 $ text "import" + <+> ppr (is_mod decl_spec) + <> parens_sp (dataType <> text "(..)") + ] + where + datacon_occ = rdrNameOcc $ ieName ie + datacon = parenSymOcc datacon_occ (ppr datacon_occ) + dataType = parenSymOcc dataType_occ (ppr dataType_occ) + source_import | mi_boot iface = text "(hi-boot interface)" + | otherwise = Outputable.empty + parens_sp d = parens (space <> d <> space) -- T( f,g ) + +badImportItemErr :: ModIface -> ImpDeclSpec -> IE GhcPs -> [AvailInfo] -> SDoc +badImportItemErr iface decl_spec ie avails + = case find checkIfDataCon avails of + Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie + Nothing -> badImportItemErrStd iface decl_spec ie + where + checkIfDataCon (AvailTC _ ns _) = + case find (\n -> importedFS == nameOccNameFS n) ns of + Just n -> isDataConName n + Nothing -> False + checkIfDataCon _ = False + availOccName = nameOccName . availName + nameOccNameFS = occNameFS . nameOccName + importedFS = occNameFS . rdrNameOcc $ ieName ie + +illegalImportItemErr :: SDoc +illegalImportItemErr = text "Illegal import item" + +dodgyImportWarn :: RdrName -> SDoc +dodgyImportWarn item + = dodgyMsg (text "import") item (dodgyMsgInsert item :: IE GhcPs) + +dodgyMsg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc +dodgyMsg kind tc ie + = sep [ text "The" <+> kind <+> ptext (sLit "item") + -- <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc)))) + <+> quotes (ppr ie) + <+> text "suggests that", + quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,", + text "but it has none" ] + +dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p) +dodgyMsgInsert tc = IEThingAll noExtField ii + where + ii :: LIEWrappedName (IdP (GhcPass p)) + ii = noLoc (IEName $ noLoc tc) + + +addDupDeclErr :: [GlobalRdrElt] -> TcRn () +addDupDeclErr [] = panic "addDupDeclErr: empty list" +addDupDeclErr gres@(gre : _) + = addErrAt (getSrcSpan (last sorted_names)) $ + -- Report the error at the later location + vcat [text "Multiple declarations of" <+> + quotes (ppr (nameOccName name)), + -- NB. print the OccName, not the Name, because the + -- latter might not be in scope in the RdrEnv and so will + -- be printed qualified. + text "Declared at:" <+> + vcat (map (ppr . nameSrcLoc) sorted_names)] + where + name = gre_name gre + sorted_names = sortWith nameSrcLoc (map gre_name gres) + + + +missingImportListWarn :: ModuleName -> SDoc +missingImportListWarn mod + = text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list") + +missingImportListItem :: IE GhcPs -> SDoc +missingImportListItem ie + = text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list") + +moduleWarn :: ModuleName -> WarningTxt -> SDoc +moduleWarn mod (WarningTxt _ txt) + = sep [ text "Module" <+> quotes (ppr mod) <> ptext (sLit ":"), + nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ] +moduleWarn mod (DeprecatedTxt _ txt) + = sep [ text "Module" <+> quotes (ppr mod) + <+> text "is deprecated:", + nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ] + +packageImportErr :: SDoc +packageImportErr + = text "Package-qualified imports are not enabled; use PackageImports" + +-- This data decl will parse OK +-- data T = a Int +-- treating "a" as the constructor. +-- It is really hard to make the parser spot this malformation. +-- So the renamer has to check that the constructor is legal +-- +-- We can get an operator as the constructor, even in the prefix form: +-- data T = :% Int Int +-- from interface files, which always print in prefix form + +checkConName :: RdrName -> TcRn () +checkConName name = checkErr (isRdrDataCon name) (badDataCon name) + +badDataCon :: RdrName -> SDoc +badDataCon name + = hsep [text "Illegal data constructor name", quotes (ppr name)] diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs new file mode 100644 index 0000000000..9b03c83681 --- /dev/null +++ b/compiler/GHC/Rename/Pat.hs @@ -0,0 +1,897 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Renaming of patterns + +Basically dependency analysis. + +Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes. In +general, all of these functions return a renamed thing, and a set of +free variables. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveFunctor #-} + +module GHC.Rename.Pat (-- main entry points + rnPat, rnPats, rnBindPat, rnPatAndThen, + + NameMaker, applyNameMaker, -- a utility for making names: + localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names, + -- sometimes we want to make top (qualified) names. + isTopRecNameMaker, + + rnHsRecFields, HsRecFieldContext(..), + rnHsRecUpdFields, + + -- CpsRn monad + CpsRn, liftCps, + + -- Literals + rnLit, rnOverLit, + + -- Pattern Error messages that are also used elsewhere + checkTupSize, patSigErr + ) where + +-- ENH: thin imports to only what is necessary for patterns + +import GhcPrelude + +import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) +import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat ) + +#include "HsVersions.h" + +import GHC.Hs +import TcRnMonad +import TcHsSyn ( hsOverLitName ) +import GHC.Rename.Env +import GHC.Rename.Fixity +import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn, bindLocalNames + , warnUnusedMatches, newLocalBndrRn + , checkUnusedRecordWildcard + , checkDupNames, checkDupAndShadowedNames + , checkTupSize , unknownSubordinateErr ) +import GHC.Rename.Types +import PrelNames +import Name +import NameSet +import RdrName +import BasicTypes +import Util +import ListSetOps ( removeDups ) +import Outputable +import SrcLoc +import Literal ( inCharRange ) +import TysWiredIn ( nilDataCon ) +import DataCon +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad ( when, ap, guard ) +import qualified Data.List.NonEmpty as NE +import Data.Ratio + +{- +********************************************************* +* * + The CpsRn Monad +* * +********************************************************* + +Note [CpsRn monad] +~~~~~~~~~~~~~~~~~~ +The CpsRn monad uses continuation-passing style to support this +style of programming: + + do { ... + ; ns <- bindNames rs + ; ...blah... } + + where rs::[RdrName], ns::[Name] + +The idea is that '...blah...' + a) sees the bindings of ns + b) returns the free variables it mentions + so that bindNames can report unused ones + +In particular, + mapM rnPatAndThen [p1, p2, p3] +has a *left-to-right* scoping: it makes the binders in +p1 scope over p2,p3. +-} + +newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars)) + -> RnM (r, FreeVars) } + deriving (Functor) + -- See Note [CpsRn monad] + +instance Applicative CpsRn where + pure x = CpsRn (\k -> k x) + (<*>) = ap + +instance Monad CpsRn where + (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k)) + +runCps :: CpsRn a -> RnM (a, FreeVars) +runCps (CpsRn m) = m (\r -> return (r, emptyFVs)) + +liftCps :: RnM a -> CpsRn a +liftCps rn_thing = CpsRn (\k -> rn_thing >>= k) + +liftCpsFV :: RnM (a, FreeVars) -> CpsRn a +liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing + ; (r,fvs2) <- k v + ; return (r, fvs1 `plusFV` fvs2) }) + +wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b) +-- Set the location, and also wrap it around the value returned +wrapSrcSpanCps fn (L loc a) + = CpsRn (\k -> setSrcSpan loc $ + unCpsRn (fn a) $ \v -> + k (L loc v)) + +lookupConCps :: Located RdrName -> CpsRn (Located Name) +lookupConCps con_rdr + = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr + ; (r, fvs) <- k con_name + ; return (r, addOneFV fvs (unLoc con_name)) }) + -- We add the constructor name to the free vars + -- See Note [Patterns are uses] + +{- +Note [Patterns are uses] +~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + module Foo( f, g ) where + data T = T1 | T2 + + f T1 = True + f T2 = False + + g _ = T1 + +Arguably we should report T2 as unused, even though it appears in a +pattern, because it never occurs in a constructed position. See +#7336. +However, implementing this in the face of pattern synonyms would be +less straightforward, since given two pattern synonyms + + pattern P1 <- P2 + pattern P2 <- () + +we need to observe the dependency between P1 and P2 so that type +checking can be done in the correct order (just like for value +bindings). Dependencies between bindings is analyzed in the renamer, +where we don't know yet whether P2 is a constructor or a pattern +synonym. So for now, we do report conid occurrences in patterns as +uses. + +********************************************************* +* * + Name makers +* * +********************************************************* + +Externally abstract type of name makers, +which is how you go from a RdrName to a Name +-} + +data NameMaker + = LamMk -- Lambdas + Bool -- True <=> report unused bindings + -- (even if True, the warning only comes out + -- if -Wunused-matches is on) + + | LetMk -- Let bindings, incl top level + -- Do *not* check for unused bindings + TopLevelFlag + MiniFixityEnv + +topRecNameMaker :: MiniFixityEnv -> NameMaker +topRecNameMaker fix_env = LetMk TopLevel fix_env + +isTopRecNameMaker :: NameMaker -> Bool +isTopRecNameMaker (LetMk TopLevel _) = True +isTopRecNameMaker _ = False + +localRecNameMaker :: MiniFixityEnv -> NameMaker +localRecNameMaker fix_env = LetMk NotTopLevel fix_env + +matchNameMaker :: HsMatchContext a -> NameMaker +matchNameMaker ctxt = LamMk report_unused + where + -- Do not report unused names in interactive contexts + -- i.e. when you type 'x <- e' at the GHCi prompt + report_unused = case ctxt of + StmtCtxt GhciStmtCtxt -> False + -- also, don't warn in pattern quotes, as there + -- is no RHS where the variables can be used! + ThPatQuote -> False + _ -> True + +rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn) +rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig) + +newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name) +newPatLName name_maker rdr_name@(L loc _) + = do { name <- newPatName name_maker rdr_name + ; return (L loc name) } + +newPatName :: NameMaker -> Located RdrName -> CpsRn Name +newPatName (LamMk report_unused) rdr_name + = CpsRn (\ thing_inside -> + do { name <- newLocalBndrRn rdr_name + ; (res, fvs) <- bindLocalNames [name] (thing_inside name) + ; when report_unused $ warnUnusedMatches [name] fvs + ; return (res, name `delFV` fvs) }) + +newPatName (LetMk is_top fix_env) rdr_name + = CpsRn (\ thing_inside -> + do { name <- case is_top of + NotTopLevel -> newLocalBndrRn rdr_name + TopLevel -> newTopSrcBinder rdr_name + ; bindLocalNames [name] $ -- Do *not* use bindLocalNameFV here + -- See Note [View pattern usage] + addLocalFixities fix_env [name] $ + thing_inside name }) + + -- Note: the bindLocalNames is somewhat suspicious + -- because it binds a top-level name as a local name. + -- however, this binding seems to work, and it only exists for + -- the duration of the patterns and the continuation; + -- then the top-level name is added to the global env + -- before going on to the RHSes (see GHC.Rename.Source). + +{- +Note [View pattern usage] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let (r, (r -> x)) = x in ... +Here the pattern binds 'r', and then uses it *only* in the view pattern. +We want to "see" this use, and in let-bindings we collect all uses and +report unused variables at the binding level. So we must use bindLocalNames +here, *not* bindLocalNameFV. #3943. + + +Note [Don't report shadowing for pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is one special context where a pattern doesn't introduce any new binders - +pattern synonym declarations. Therefore we don't check to see if pattern +variables shadow existing identifiers as they are never bound to anything +and have no scope. + +Without this check, there would be quite a cryptic warning that the `x` +in the RHS of the pattern synonym declaration shadowed the top level `x`. + +``` +x :: () +x = () + +pattern P x = Just x +``` + +See #12615 for some more examples. + +********************************************************* +* * + External entry points +* * +********************************************************* + +There are various entry points to renaming patterns, depending on + (1) whether the names created should be top-level names or local names + (2) whether the scope of the names is entirely given in a continuation + (e.g., in a case or lambda, but not in a let or at the top-level, + because of the way mutually recursive bindings are handled) + (3) whether the a type signature in the pattern can bind + lexically-scoped type variables (for unpacking existential + type vars in data constructors) + (4) whether we do duplicate and unused variable checking + (5) whether there are fixity declarations associated with the names + bound by the patterns that need to be brought into scope with them. + + Rather than burdening the clients of this module with all of these choices, + we export the three points in this design space that we actually need: +-} + +-- ----------- Entry point 1: rnPats ------------------- +-- Binds local names; the scope of the bindings is entirely in the thing_inside +-- * allows type sigs to bind type vars +-- * local namemaker +-- * unused and duplicate checking +-- * no fixities +rnPats :: HsMatchContext Name -- for error messages + -> [LPat GhcPs] + -> ([LPat GhcRn] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnPats ctxt pats thing_inside + = do { envs_before <- getRdrEnvs + + -- (1) rename the patterns, bringing into scope all of the term variables + -- (2) then do the thing inside. + ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do + { -- Check for duplicated and shadowed names + -- Must do this *after* renaming the patterns + -- See Note [Collect binders only after renaming] in GHC.Hs.Utils + -- Because we don't bind the vars all at once, we can't + -- check incrementally for duplicates; + -- Nor can we check incrementally for shadowing, else we'll + -- complain *twice* about duplicates e.g. f (x,x) = ... + -- + -- See note [Don't report shadowing for pattern synonyms] + ; let bndrs = collectPatsBinders pats' + ; addErrCtxt doc_pat $ + if isPatSynCtxt ctxt + then checkDupNames bndrs + else checkDupAndShadowedNames envs_before bndrs + ; thing_inside pats' } } + where + doc_pat = text "In" <+> pprMatchContext ctxt + +rnPat :: HsMatchContext Name -- for error messages + -> LPat GhcPs + -> (LPat GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) -- Variables bound by pattern do not + -- appear in the result FreeVars +rnPat ctxt pat thing_inside + = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat') + +applyNameMaker :: NameMaker -> Located RdrName -> RnM (Located Name) +applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr) + ; return n } + +-- ----------- Entry point 2: rnBindPat ------------------- +-- Binds local names; in a recursive scope that involves other bound vars +-- e.g let { (x, Just y) = e1; ... } in ... +-- * does NOT allows type sig to bind type vars +-- * local namemaker +-- * no unused and duplicate checking +-- * fixities might be coming in +rnBindPat :: NameMaker + -> LPat GhcPs + -> RnM (LPat GhcRn, FreeVars) + -- Returned FreeVars are the free variables of the pattern, + -- of course excluding variables bound by this pattern + +rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat) + +{- +********************************************************* +* * + The main event +* * +********************************************************* +-} + +-- ----------- Entry point 3: rnLPatAndThen ------------------- +-- General version: parametrized by how you make new names + +rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn] +rnLPatsAndThen mk = mapM (rnLPatAndThen mk) + -- Despite the map, the monad ensures that each pattern binds + -- variables that may be mentioned in subsequent patterns in the list + +-------------------- +-- The workhorse +rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn) +rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat + +rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn) +rnPatAndThen _ (WildPat _) = return (WildPat noExtField) +rnPatAndThen mk (ParPat x pat) = do { pat' <- rnLPatAndThen mk pat + ; return (ParPat x pat') } +rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat + ; return (LazyPat x pat') } +rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat + ; return (BangPat x pat') } +rnPatAndThen mk (VarPat x (L l rdr)) + = do { loc <- liftCps getSrcSpanM + ; name <- newPatName mk (L loc rdr) + ; return (VarPat x (L l name)) } + -- we need to bind pattern variables for view pattern expressions + -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) + +rnPatAndThen mk (SigPat x pat sig) + -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is + -- important to rename its type signature _before_ renaming the rest of the + -- pattern, so that type variables are first bound by the _outermost_ pattern + -- type signature they occur in. This keeps the type checker happy when + -- pattern type signatures happen to be nested (#7827) + -- + -- f ((Just (x :: a) :: Maybe a) + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^ `a' is first bound here + -- ~~~~~~~~~~~~~~~^ the same `a' then used here + = do { sig' <- rnHsSigCps sig + ; pat' <- rnLPatAndThen mk pat + ; return (SigPat x pat' sig' ) } + +rnPatAndThen mk (LitPat x lit) + | HsString src s <- lit + = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings) + ; if ovlStr + then rnPatAndThen mk + (mkNPat (noLoc (mkHsIsString src s)) + Nothing) + else normal_lit } + | otherwise = normal_lit + where + normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) } + +rnPatAndThen _ (NPat x (L l lit) mb_neg _eq) + = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit + ; mb_neg' -- See Note [Negative zero] + <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName + ; return (Just neg, fvs) } + positive = return (Nothing, emptyFVs) + in liftCpsFV $ case (mb_neg , mb_neg') of + (Nothing, Just _ ) -> negative + (Just _ , Nothing) -> negative + (Nothing, Nothing) -> positive + (Just _ , Just _ ) -> positive + ; eq' <- liftCpsFV $ lookupSyntaxName eqName + ; return (NPat x (L l lit') mb_neg' eq') } + +rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ ) + = do { new_name <- newPatName mk rdr + ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero] + -- We skip negateName as + -- negative zero doesn't make + -- sense in n + k patterns + ; minus <- liftCpsFV $ lookupSyntaxName minusName + ; ge <- liftCpsFV $ lookupSyntaxName geName + ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name) + (L l lit') lit' ge minus) } + -- The Report says that n+k patterns must be in Integral + +rnPatAndThen mk (AsPat x rdr pat) + = do { new_name <- newPatLName mk rdr + ; pat' <- rnLPatAndThen mk pat + ; return (AsPat x new_name pat') } + +rnPatAndThen mk p@(ViewPat x expr pat) + = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns + ; checkErr vp_flag (badViewPat p) } + -- Because of the way we're arranging the recursive calls, + -- this will be in the right context + ; expr' <- liftCpsFV $ rnLExpr expr + ; pat' <- rnLPatAndThen mk pat + -- Note: at this point the PreTcType in ty can only be a placeHolder + -- ; return (ViewPat expr' pat' ty) } + ; return (ViewPat x expr' pat') } + +rnPatAndThen mk (ConPatIn con stuff) + -- rnConPatAndThen takes care of reconstructing the pattern + -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on. + = case unLoc con == nameRdrName (dataConName nilDataCon) of + True -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists + ; if ol_flag then rnPatAndThen mk (ListPat noExtField []) + else rnConPatAndThen mk con stuff} + False -> rnConPatAndThen mk con stuff + +rnPatAndThen mk (ListPat _ pats) + = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists + ; pats' <- rnLPatsAndThen mk pats + ; case opt_OverloadedLists of + True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName + ; return (ListPat (Just to_list_name) pats')} + False -> return (ListPat Nothing pats') } + +rnPatAndThen mk (TuplePat x pats boxed) + = do { liftCps $ checkTupSize (length pats) + ; pats' <- rnLPatsAndThen mk pats + ; return (TuplePat x pats' boxed) } + +rnPatAndThen mk (SumPat x pat alt arity) + = do { pat <- rnLPatAndThen mk pat + ; return (SumPat x pat alt arity) + } + +-- If a splice has been run already, just rename the result. +rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat))) + = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat + +rnPatAndThen mk (SplicePat _ splice) + = do { eith <- liftCpsFV $ rnSplicePat splice + ; case eith of -- See Note [rnSplicePat] in GHC.Rename.Splice + Left not_yet_renamed -> rnPatAndThen mk not_yet_renamed + Right already_renamed -> return already_renamed } + +rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat) + + +-------------------- +rnConPatAndThen :: NameMaker + -> Located RdrName -- the constructor + -> HsConPatDetails GhcPs + -> CpsRn (Pat GhcRn) + +rnConPatAndThen mk con (PrefixCon pats) + = do { con' <- lookupConCps con + ; pats' <- rnLPatsAndThen mk pats + ; return (ConPatIn con' (PrefixCon pats')) } + +rnConPatAndThen mk con (InfixCon pat1 pat2) + = do { con' <- lookupConCps con + ; pat1' <- rnLPatAndThen mk pat1 + ; pat2' <- rnLPatAndThen mk pat2 + ; fixity <- liftCps $ lookupFixityRn (unLoc con') + ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' } + +rnConPatAndThen mk con (RecCon rpats) + = do { con' <- lookupConCps con + ; rpats' <- rnHsRecPatsAndThen mk con' rpats + ; return (ConPatIn con' (RecCon rpats')) } + +checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn () +checkUnusedRecordWildcardCps loc dotdot_names = + CpsRn (\thing -> do + (r, fvs) <- thing () + checkUnusedRecordWildcard loc fvs dotdot_names + return (r, fvs) ) +-------------------- +rnHsRecPatsAndThen :: NameMaker + -> Located Name -- Constructor + -> HsRecFields GhcPs (LPat GhcPs) + -> CpsRn (HsRecFields GhcRn (LPat GhcRn)) +rnHsRecPatsAndThen mk (L _ con) + hs_rec_fields@(HsRecFields { rec_dotdot = dd }) + = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat + hs_rec_fields + ; flds' <- mapM rn_field (flds `zip` [1..]) + ; check_unused_wildcard (implicit_binders flds' <$> dd) + ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) } + where + mkVarPat l n = VarPat noExtField (L l n) + rn_field (L l fld, n') = + do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld) + ; return (L l (fld { hsRecFieldArg = arg' })) } + + loc = maybe noSrcSpan getLoc dd + + -- Get the arguments of the implicit binders + implicit_binders fs (unLoc -> n) = collectPatsBinders implicit_pats + where + implicit_pats = map (hsRecFieldArg . unLoc) (drop n fs) + + -- Don't warn for let P{..} = ... in ... + check_unused_wildcard = case mk of + LetMk{} -> const (return ()) + LamMk{} -> checkUnusedRecordWildcardCps loc + + -- Suppress unused-match reporting for fields introduced by ".." + nested_mk Nothing mk _ = mk + nested_mk (Just _) mk@(LetMk {}) _ = mk + nested_mk (Just (unLoc -> n)) (LamMk report_unused) n' + = LamMk (report_unused && (n' <= n)) + +{- +************************************************************************ +* * + Record fields +* * +************************************************************************ +-} + +data HsRecFieldContext + = HsRecFieldCon Name + | HsRecFieldPat Name + | HsRecFieldUpd + +rnHsRecFields + :: forall arg. + HsRecFieldContext + -> (SrcSpan -> RdrName -> arg) + -- When punning, use this to build a new field + -> HsRecFields GhcPs (Located arg) + -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars) + +-- This surprisingly complicated pass +-- a) looks up the field name (possibly using disambiguation) +-- b) fills in puns and dot-dot stuff +-- When we've finished, we've renamed the LHS, but not the RHS, +-- of each x=e binding +-- +-- This is used for record construction and pattern-matching, but not updates. + +rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) + = do { pun_ok <- xoptM LangExt.RecordPuns + ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields + ; let parent = guard disambig_ok >> mb_con + ; flds1 <- mapM (rn_fld pun_ok parent) flds + ; mapM_ (addErr . dupFieldErr ctxt) dup_flds + ; dotdot_flds <- rn_dotdot dotdot mb_con flds1 + ; let all_flds | null dotdot_flds = flds1 + | otherwise = flds1 ++ dotdot_flds + ; return (all_flds, mkFVs (getFieldIds all_flds)) } + where + mb_con = case ctxt of + HsRecFieldCon con -> Just con + HsRecFieldPat con -> Just con + _ {- update -} -> Nothing + + rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg) + -> RnM (LHsRecField GhcRn (Located arg)) + rn_fld pun_ok parent (L l + (HsRecField + { hsRecFieldLbl = + (L loc (FieldOcc _ (L ll lbl))) + , hsRecFieldArg = arg + , hsRecPun = pun })) + = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl + ; arg' <- if pun + then do { checkErr pun_ok (badPun (L loc lbl)) + -- Discard any module qualifier (#11662) + ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) + ; return (L loc (mk_arg loc arg_rdr)) } + else return arg + ; return (L l (HsRecField + { hsRecFieldLbl = (L loc (FieldOcc + sel (L ll lbl))) + , hsRecFieldArg = arg' + , hsRecPun = pun })) } + rn_fld _ _ (L _ (HsRecField (L _ (XFieldOcc _)) _ _)) + = panic "rnHsRecFields" + + + rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in GHC.Hs.Pat + -> Maybe Name -- The constructor (Nothing for an + -- out of scope constructor) + -> [LHsRecField GhcRn (Located arg)] -- Explicit fields + -> RnM ([LHsRecField GhcRn (Located arg)]) -- Field Labels we need to fill in + rn_dotdot (Just (L loc n)) (Just con) flds -- ".." on record construction / pat match + | not (isUnboundName con) -- This test is because if the constructor + -- isn't in scope the constructor lookup will add + -- an error but still return an unbound name. We + -- don't want that to screw up the dot-dot fill-in stuff. + = ASSERT( flds `lengthIs` n ) + do { dd_flag <- xoptM LangExt.RecordWildCards + ; checkErr dd_flag (needFlagDotDot ctxt) + ; (rdr_env, lcl_env) <- getRdrEnvs + ; con_fields <- lookupConstructorFields con + ; when (null con_fields) (addErr (badDotDotCon con)) + ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds) + + -- For constructor uses (but not patterns) + -- the arg should be in scope locally; + -- i.e. not top level or imported + -- Eg. data R = R { x,y :: Int } + -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y} + arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env + + (dot_dot_fields, dot_dot_gres) + = unzip [ (fl, gre) + | fl <- con_fields + , let lbl = mkVarOccFS (flLabel fl) + , not (lbl `elemOccSet` present_flds) + , Just gre <- [lookupGRE_FieldLabel rdr_env fl] + -- Check selector is in scope + , case ctxt of + HsRecFieldCon {} -> arg_in_scope lbl + _other -> True ] + + ; addUsedGREs dot_dot_gres + ; return [ L loc (HsRecField + { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr)) + , hsRecFieldArg = L loc (mk_arg loc arg_rdr) + , hsRecPun = False }) + | fl <- dot_dot_fields + , let sel = flSelector fl + , let arg_rdr = mkVarUnqual (flLabel fl) ] } + + rn_dotdot _dotdot _mb_con _flds + = return [] + -- _dotdot = Nothing => No ".." at all + -- _mb_con = Nothing => Record update + -- _mb_con = Just unbound => Out of scope data constructor + + dup_flds :: [NE.NonEmpty RdrName] + -- Each list represents a RdrName that occurred more than once + -- (the list contains all occurrences) + -- Each list in dup_fields is non-empty + (_, dup_flds) = removeDups compare (getFieldLbls flds) + + +-- NB: Consider this: +-- module Foo where { data R = R { fld :: Int } } +-- module Odd where { import Foo; fld x = x { fld = 3 } } +-- Arguably this should work, because the reference to 'fld' is +-- unambiguous because there is only one field id 'fld' in scope. +-- But currently it's rejected. + +rnHsRecUpdFields + :: [LHsRecUpdField GhcPs] + -> RnM ([LHsRecUpdField GhcRn], FreeVars) +rnHsRecUpdFields flds + = do { pun_ok <- xoptM LangExt.RecordPuns + ; overload_ok <- xoptM LangExt.DuplicateRecordFields + ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds + ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds + + -- Check for an empty record update e {} + -- NB: don't complain about e { .. }, because rn_dotdot has done that already + ; when (null flds) $ addErr emptyUpdateErr + + ; return (flds1, plusFVs fvss) } + where + doc = text "constructor field name" + + rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs + -> RnM (LHsRecUpdField GhcRn, FreeVars) + rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f + , hsRecFieldArg = arg + , hsRecPun = pun })) + = do { let lbl = rdrNameAmbiguousFieldOcc f + ; sel <- setSrcSpan loc $ + -- Defer renaming of overloaded fields to the typechecker + -- See Note [Disambiguating record fields] in TcExpr + if overload_ok + then do { mb <- lookupGlobalOccRn_overloaded + overload_ok lbl + ; case mb of + Nothing -> + do { addErr + (unknownSubordinateErr doc lbl) + ; return (Right []) } + Just r -> return r } + else fmap Left $ lookupGlobalOccRn lbl + ; arg' <- if pun + then do { checkErr pun_ok (badPun (L loc lbl)) + -- Discard any module qualifier (#11662) + ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) + ; return (L loc (HsVar noExtField (L loc arg_rdr))) } + else return arg + ; (arg'', fvs) <- rnLExpr arg' + + ; let fvs' = case sel of + Left sel_name -> fvs `addOneFV` sel_name + Right [sel_name] -> fvs `addOneFV` sel_name + Right _ -> fvs + lbl' = case sel of + Left sel_name -> + L loc (Unambiguous sel_name (L loc lbl)) + Right [sel_name] -> + L loc (Unambiguous sel_name (L loc lbl)) + Right _ -> L loc (Ambiguous noExtField (L loc lbl)) + + ; return (L l (HsRecField { hsRecFieldLbl = lbl' + , hsRecFieldArg = arg'' + , hsRecPun = pun }), fvs') } + + dup_flds :: [NE.NonEmpty RdrName] + -- Each list represents a RdrName that occurred more than once + -- (the list contains all occurrences) + -- Each list in dup_fields is non-empty + (_, dup_flds) = removeDups compare (getFieldUpdLbls flds) + + + +getFieldIds :: [LHsRecField GhcRn arg] -> [Name] +getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds + +getFieldLbls :: [LHsRecField id arg] -> [RdrName] +getFieldLbls flds + = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds + +getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName] +getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds + +needFlagDotDot :: HsRecFieldContext -> SDoc +needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt, + text "Use RecordWildCards to permit this"] + +badDotDotCon :: Name -> SDoc +badDotDotCon con + = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con) + , nest 2 (text "The constructor has no labelled fields") ] + +emptyUpdateErr :: SDoc +emptyUpdateErr = text "Empty record update" + +badPun :: Located RdrName -> SDoc +badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld), + text "Use NamedFieldPuns to permit this"] + +dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc +dupFieldErr ctxt dups + = hsep [text "duplicate field name", + quotes (ppr (NE.head dups)), + text "in record", pprRFC ctxt] + +pprRFC :: HsRecFieldContext -> SDoc +pprRFC (HsRecFieldCon {}) = text "construction" +pprRFC (HsRecFieldPat {}) = text "pattern" +pprRFC (HsRecFieldUpd {}) = text "update" + +{- +************************************************************************ +* * +\subsubsection{Literals} +* * +************************************************************************ + +When literals occur we have to make sure +that the types and classes they involve +are made available. +-} + +rnLit :: HsLit p -> RnM () +rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c) +rnLit _ = return () + +-- Turn a Fractional-looking literal which happens to be an integer into an +-- Integer-looking literal. +generalizeOverLitVal :: OverLitVal -> OverLitVal +generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_neg=neg,fl_value=val})) + | denominator val == 1 = HsIntegral (IL { il_text=src + , il_neg=neg + , il_value=numerator val}) +generalizeOverLitVal lit = lit + +isNegativeZeroOverLit :: HsOverLit t -> Bool +isNegativeZeroOverLit lit + = case ol_val lit of + HsIntegral i -> 0 == il_value i && il_neg i + HsFractional f -> 0 == fl_value f && fl_neg f + _ -> False + +{- +Note [Negative zero] +~~~~~~~~~~~~~~~~~~~~~~~~~ +There were problems with negative zero in conjunction with Negative Literals +extension. Numeric literal value is contained in Integer and Rational types +inside IntegralLit and FractionalLit. These types cannot represent negative +zero value. So we had to add explicit field 'neg' which would hold information +about literal sign. Here in rnOverLit we use it to detect negative zeroes and +in this case return not only literal itself but also negateName so that users +can apply it explicitly. In this case it stays negative zero. #13211 +-} + +rnOverLit :: HsOverLit t -> + RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars) +rnOverLit origLit + = do { opt_NumDecimals <- xoptM LangExt.NumDecimals + ; let { lit@(OverLit {ol_val=val}) + | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)} + | otherwise = origLit + } + ; let std_name = hsOverLitName val + ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1) + <- lookupSyntaxName std_name + ; let rebindable = case from_thing_name of + HsVar _ lv -> (unLoc lv) /= std_name + _ -> panic "rnOverLit" + ; let lit' = lit { ol_witness = from_thing_name + , ol_ext = rebindable } + ; if isNegativeZeroOverLit lit' + then do { (SyntaxExpr { syn_expr = negate_name }, fvs2) + <- lookupSyntaxName negateName + ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name) + , fvs1 `plusFV` fvs2) } + else return ((lit', Nothing), fvs1) } + +{- +************************************************************************ +* * +\subsubsection{Errors} +* * +************************************************************************ +-} + +patSigErr :: Outputable a => a -> SDoc +patSigErr ty + = (text "Illegal signature in pattern:" <+> ppr ty) + $$ nest 4 (text "Use ScopedTypeVariables to permit it") + +bogusCharError :: Char -> SDoc +bogusCharError c + = text "character literal out of range: '\\" <> char c <> char '\'' + +badViewPat :: Pat GhcPs -> SDoc +badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat, + text "Use ViewPatterns to enable view patterns"] diff --git a/compiler/GHC/Rename/Source.hs b/compiler/GHC/Rename/Source.hs new file mode 100644 index 0000000000..648dc29456 --- /dev/null +++ b/compiler/GHC/Rename/Source.hs @@ -0,0 +1,2415 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Main pass of renamer +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Rename.Source ( + rnSrcDecls, addTcgDUs, findSplice + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr ) +import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls ) + +import GHC.Hs +import FieldLabel +import RdrName +import GHC.Rename.Types +import GHC.Rename.Binds +import GHC.Rename.Env +import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames + , checkDupRdrNames, inHsDocContext, bindLocalNamesFV + , checkShadowedRdrNames, warnUnusedTypePatterns + , extendTyVarEnvFVRn, newLocalBndrsRn + , withHsDocContext ) +import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr ) +import GHC.Rename.Names +import GHC.Rename.Doc ( rnHsDoc, rnMbLHsDoc ) +import TcAnnotations ( annCtxt ) +import TcRnMonad + +import ForeignCall ( CCallTarget(..) ) +import Module +import HscTypes ( Warnings(..), plusWarns ) +import PrelNames ( applicativeClassName, pureAName, thenAName + , monadClassName, returnMName, thenMName + , semigroupClassName, sappendName + , monoidClassName, mappendName + ) +import Name +import NameSet +import NameEnv +import Avail +import Outputable +import Bag +import BasicTypes ( pprRuleName, TypeOrKind(..) ) +import FastString +import SrcLoc +import DynFlags +import Util ( debugIsOn, filterOut, lengthExceeds, partitionWith ) +import HscTypes ( HscEnv, hsc_dflags ) +import ListSetOps ( findDupsEq, removeDups, equivClasses ) +import Digraph ( SCC, flattenSCC, flattenSCCs, Node(..) + , stronglyConnCompFromEdgedVerticesUniq ) +import UniqSet +import OrdList +import qualified GHC.LanguageExtensions as LangExt + +import Control.Monad +import Control.Arrow ( first ) +import Data.List ( mapAccumL ) +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.Maybe ( isNothing, fromMaybe, mapMaybe ) +import qualified Data.Set as Set ( difference, fromList, toList, null ) +import Data.Function ( on ) + +{- | @rnSourceDecl@ "renames" declarations. +It simultaneously performs dependency analysis and precedence parsing. +It also does the following error checks: + +* Checks that tyvars are used properly. This includes checking + for undefined tyvars, and tyvars in contexts that are ambiguous. + (Some of this checking has now been moved to module @TcMonoType@, + since we don't have functional dependency information at this point.) + +* Checks that all variable occurrences are defined. + +* Checks the @(..)@ etc constraints in the export list. + +Brings the binders of the group into scope in the appropriate places; +does NOT assume that anything is in scope already +-} +rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn) +-- Rename a top-level HsGroup; used for normal source files *and* hs-boot files +rnSrcDecls group@(HsGroup { hs_valds = val_decls, + hs_splcds = splice_decls, + hs_tyclds = tycl_decls, + hs_derivds = deriv_decls, + hs_fixds = fix_decls, + hs_warnds = warn_decls, + hs_annds = ann_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls, + hs_docs = docs }) + = do { + -- (A) Process the fixity declarations, creating a mapping from + -- FastStrings to FixItems. + -- Also checks for duplicates. + local_fix_env <- makeMiniFixityEnv fix_decls ; + + -- (B) Bring top level binders (and their fixities) into scope, + -- *except* for the value bindings, which get done in step (D) + -- with collectHsIdBinders. However *do* include + -- + -- * Class ops, data constructors, and record fields, + -- because they do not have value declarations. + -- + -- * For hs-boot files, include the value signatures + -- Again, they have no value declarations + -- + (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ; + + + setEnvs tc_envs $ do { + + failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations + + -- (D1) Bring pattern synonyms into scope. + -- Need to do this before (D2) because rnTopBindsLHS + -- looks up those pattern synonyms (#9889) + + extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do { + + -- (D2) Rename the left-hand sides of the value bindings. + -- This depends on everything from (B) being in scope. + -- It uses the fixity env from (A) to bind fixities for view patterns. + new_lhs <- rnTopBindsLHS local_fix_env val_decls ; + + -- Bind the LHSes (and their fixities) in the global rdr environment + let { id_bndrs = collectHsIdBinders new_lhs } ; -- Excludes pattern-synonym binders + -- They are already in scope + traceRn "rnSrcDecls" (ppr id_bndrs) ; + tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ; + setEnvs tc_envs $ do { + + -- Now everything is in scope, as the remaining renaming assumes. + + -- (E) Rename type and class decls + -- (note that value LHSes need to be in scope for default methods) + -- + -- You might think that we could build proper def/use information + -- for type and class declarations, but they can be involved + -- in mutual recursion across modules, and we only do the SCC + -- analysis for them in the type checker. + -- So we content ourselves with gathering uses only; that + -- means we'll only report a declaration as unused if it isn't + -- mentioned at all. Ah well. + traceRn "Start rnTyClDecls" (ppr tycl_decls) ; + (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ; + + -- (F) Rename Value declarations right-hand sides + traceRn "Start rnmono" empty ; + let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ; + is_boot <- tcIsHsBootOrSig ; + (rn_val_decls, bind_dus) <- if is_boot + -- For an hs-boot, use tc_bndrs (which collects how we're renamed + -- signatures), since val_bndr_set is empty (there are no x = ... + -- bindings in an hs-boot.) + then rnTopBindsBoot tc_bndrs new_lhs + else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ; + traceRn "finish rnmono" (ppr rn_val_decls) ; + + -- (G) Rename Fixity and deprecations + + -- Rename fixity declarations and error if we try to + -- fix something from another module (duplicates were checked in (A)) + let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ; + rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs))) + fix_decls ; + + -- Rename deprec decls; + -- check for duplicates and ensure that deprecated things are defined locally + -- at the moment, we don't keep these around past renaming + rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ; + + -- (H) Rename Everything else + + (rn_rule_decls, src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $ + rnList rnHsRuleDecls rule_decls ; + -- Inside RULES, scoped type variables are on + (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ; + (rn_ann_decls, src_fvs4) <- rnList rnAnnDecl ann_decls ; + (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ; + (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ; + (rn_splice_decls, src_fvs7) <- rnList rnSpliceDecl splice_decls ; + -- Haddock docs; no free vars + rn_docs <- mapM (wrapLocM rnDocDecl) docs ; + + last_tcg_env <- getGblEnv ; + -- (I) Compute the results and return + let {rn_group = HsGroup { hs_ext = noExtField, + hs_valds = rn_val_decls, + hs_splcds = rn_splice_decls, + hs_tyclds = rn_tycl_decls, + hs_derivds = rn_deriv_decls, + hs_fixds = rn_fix_decls, + hs_warnds = [], -- warns are returned in the tcg_env + -- (see below) not in the HsGroup + hs_fords = rn_foreign_decls, + hs_annds = rn_ann_decls, + hs_defds = rn_default_decls, + hs_ruleds = rn_rule_decls, + hs_docs = rn_docs } ; + + tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ; + other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ; + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, + src_fvs5, src_fvs6, src_fvs7] ; + -- It is tiresome to gather the binders from type and class decls + + src_dus = unitOL other_def `plusDU` bind_dus `plusDU` usesOnly other_fvs ; + -- Instance decls may have occurrences of things bound in bind_dus + -- so we must put other_fvs last + + final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus) + in -- we return the deprecs in the env, not in the HsGroup above + tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns }; + } ; + traceRn "finish rnSrc" (ppr rn_group) ; + traceRn "finish Dus" (ppr src_dus ) ; + return (final_tcg_env, rn_group) + }}}} +rnSrcDecls (XHsGroup nec) = noExtCon nec + +addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv +-- This function could be defined lower down in the module hierarchy, +-- but there doesn't seem anywhere very logical to put it. +addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } + +rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars) +rnList f xs = mapFvRn (wrapLocFstM f) xs + +{- +********************************************************* +* * + HsDoc stuff +* * +********************************************************* +-} + +rnDocDecl :: DocDecl -> RnM DocDecl +rnDocDecl (DocCommentNext doc) = do + rn_doc <- rnHsDoc doc + return (DocCommentNext rn_doc) +rnDocDecl (DocCommentPrev doc) = do + rn_doc <- rnHsDoc doc + return (DocCommentPrev rn_doc) +rnDocDecl (DocCommentNamed str doc) = do + rn_doc <- rnHsDoc doc + return (DocCommentNamed str rn_doc) +rnDocDecl (DocGroup lev doc) = do + rn_doc <- rnHsDoc doc + return (DocGroup lev rn_doc) + +{- +********************************************************* +* * + Source-code deprecations declarations +* * +********************************************************* + +Check that the deprecated names are defined, are defined locally, and +that there are no duplicate deprecations. + +It's only imported deprecations, dealt with in RnIfaces, that we +gather them together. +-} + +-- checks that the deprecations are defined locally, and that there are no duplicates +rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings +rnSrcWarnDecls _ [] + = return NoWarnings + +rnSrcWarnDecls bndr_set decls' + = do { -- check for duplicates + ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups + in addErrAt loc (dupWarnDecl lrdr' rdr)) + warn_rdr_dups + ; pairs_s <- mapM (addLocM rn_deprec) decls + ; return (WarnSome ((concat pairs_s))) } + where + decls = concatMap (wd_warnings . unLoc) decls' + + sig_ctxt = TopSigCtxt bndr_set + + rn_deprec (Warning _ rdr_names txt) + -- ensures that the names are defined locally + = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) + rdr_names + ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] } + rn_deprec (XWarnDecl nec) = noExtCon nec + + what = text "deprecation" + + warn_rdr_dups = findDupRdrNames + $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls + +findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)] +findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) + +-- look for duplicates among the OccNames; +-- we check that the names are defined above +-- invt: the lists returned by findDupsEq always have at least two elements + +dupWarnDecl :: Located RdrName -> RdrName -> SDoc +-- Located RdrName -> DeprecDecl RdrName -> SDoc +dupWarnDecl d rdr_name + = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name), + text "also at " <+> ppr (getLoc d)] + +{- +********************************************************* +* * +\subsection{Annotation declarations} +* * +********************************************************* +-} + +rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars) +rnAnnDecl ann@(HsAnnotation _ s provenance expr) + = addErrCtxt (annCtxt ann) $ + do { (provenance', provenance_fvs) <- rnAnnProvenance provenance + ; (expr', expr_fvs) <- setStage (Splice Untyped) $ + rnLExpr expr + ; return (HsAnnotation noExtField s provenance' expr', + provenance_fvs `plusFV` expr_fvs) } +rnAnnDecl (XAnnDecl nec) = noExtCon nec + +rnAnnProvenance :: AnnProvenance RdrName + -> RnM (AnnProvenance Name, FreeVars) +rnAnnProvenance provenance = do + provenance' <- traverse lookupTopBndrRn provenance + return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) + +{- +********************************************************* +* * +\subsection{Default declarations} +* * +********************************************************* +-} + +rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars) +rnDefaultDecl (DefaultDecl _ tys) + = do { (tys', fvs) <- rnLHsTypes doc_str tys + ; return (DefaultDecl noExtField tys', fvs) } + where + doc_str = DefaultDeclCtx +rnDefaultDecl (XDefaultDecl nec) = noExtCon nec + +{- +********************************************************* +* * +\subsection{Foreign declarations} +* * +********************************************************* +-} + +rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) +rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) + = do { topEnv :: HscEnv <- getTopEnv + ; name' <- lookupLocatedTopBndrRn name + ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty + + -- Mark any PackageTarget style imports as coming from the current package + ; let unitId = thisPackage $ hsc_dflags topEnv + spec' = patchForeignImport unitId spec + + ; return (ForeignImport { fd_i_ext = noExtField + , fd_name = name', fd_sig_ty = ty' + , fd_fi = spec' }, fvs) } + +rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec }) + = do { name' <- lookupLocatedOccRn name + ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty + ; return (ForeignExport { fd_e_ext = noExtField + , fd_name = name', fd_sig_ty = ty' + , fd_fe = spec } + , fvs `addOneFV` unLoc name') } + -- NB: a foreign export is an *occurrence site* for name, so + -- we add it to the free-variable list. It might, for example, + -- be imported from another module + +rnHsForeignDecl (XForeignDecl nec) = noExtCon nec + +-- | For Windows DLLs we need to know what packages imported symbols are from +-- to generate correct calls. Imported symbols are tagged with the current +-- package, so if they get inlined across a package boundary we'll still +-- know where they're from. +-- +patchForeignImport :: UnitId -> ForeignImport -> ForeignImport +patchForeignImport unitId (CImport cconv safety fs spec src) + = CImport cconv safety fs (patchCImportSpec unitId spec) src + +patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec +patchCImportSpec unitId spec + = case spec of + CFunction callTarget -> CFunction $ patchCCallTarget unitId callTarget + _ -> spec + +patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget +patchCCallTarget unitId callTarget = + case callTarget of + StaticTarget src label Nothing isFun + -> StaticTarget src label (Just unitId) isFun + _ -> callTarget + +{- +********************************************************* +* * +\subsection{Instance declarations} +* * +********************************************************* +-} + +rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) +rnSrcInstDecl (TyFamInstD { tfid_inst = tfi }) + = do { (tfi', fvs) <- rnTyFamInstDecl NonAssocTyFamEqn tfi + ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) } + +rnSrcInstDecl (DataFamInstD { dfid_inst = dfi }) + = do { (dfi', fvs) <- rnDataFamInstDecl NonAssocTyFamEqn dfi + ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) } + +rnSrcInstDecl (ClsInstD { cid_inst = cid }) + = do { traceRn "rnSrcIstDecl {" (ppr cid) + ; (cid', fvs) <- rnClsInstDecl cid + ; traceRn "rnSrcIstDecl end }" empty + ; return (ClsInstD { cid_d_ext = noExtField, cid_inst = cid' }, fvs) } + +rnSrcInstDecl (XInstDecl nec) = noExtCon nec + +-- | Warn about non-canonical typeclass instance declarations +-- +-- A "non-canonical" instance definition can occur for instances of a +-- class which redundantly defines an operation its superclass +-- provides as well (c.f. `return`/`pure`). In such cases, a canonical +-- instance is one where the subclass inherits its method +-- implementation from its superclass instance (usually the subclass +-- has a default method implementation to that effect). Consequently, +-- a non-canonical instance occurs when this is not the case. +-- +-- See also descriptions of 'checkCanonicalMonadInstances' and +-- 'checkCanonicalMonoidInstances' +checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM () +checkCanonicalInstances cls poly_ty mbinds = do + whenWOptM Opt_WarnNonCanonicalMonadInstances + checkCanonicalMonadInstances + + whenWOptM Opt_WarnNonCanonicalMonoidInstances + checkCanonicalMonoidInstances + + where + -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance + -- declarations. Specifically, the following conditions are verified: + -- + -- In 'Monad' instances declarations: + -- + -- * If 'return' is overridden it must be canonical (i.e. @return = pure@) + -- * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@) + -- + -- In 'Applicative' instance declarations: + -- + -- * Warn if 'pure' is defined backwards (i.e. @pure = return@). + -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@). + -- + checkCanonicalMonadInstances + | cls == applicativeClassName = do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == pureAName, isAliasMG mg == Just returnMName + -> addWarnNonCanonicalMethod1 + Opt_WarnNonCanonicalMonadInstances "pure" "return" + + | name == thenAName, isAliasMG mg == Just thenMName + -> addWarnNonCanonicalMethod1 + Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)" + + _ -> return () + + | cls == monadClassName = do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == returnMName, isAliasMG mg /= Just pureAName + -> addWarnNonCanonicalMethod2 + Opt_WarnNonCanonicalMonadInstances "return" "pure" + + | name == thenMName, isAliasMG mg /= Just thenAName + -> addWarnNonCanonicalMethod2 + Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)" + + _ -> return () + + | otherwise = return () + + -- | Check whether Monoid(mappend) is defined in terms of + -- Semigroup((<>)) (and not the other way round). Specifically, + -- the following conditions are verified: + -- + -- In 'Monoid' instances declarations: + -- + -- * If 'mappend' is overridden it must be canonical + -- (i.e. @mappend = (<>)@) + -- + -- In 'Semigroup' instance declarations: + -- + -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@). + -- + checkCanonicalMonoidInstances + | cls == semigroupClassName = do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == sappendName, isAliasMG mg == Just mappendName + -> addWarnNonCanonicalMethod1 + Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend" + + _ -> return () + + | cls == monoidClassName = do + forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do + case mbind of + FunBind { fun_id = L _ name + , fun_matches = mg } + | name == mappendName, isAliasMG mg /= Just sappendName + -> addWarnNonCanonicalMethod2NoDefault + Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)" + + _ -> return () + + | otherwise = return () + + -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\" + -- binding, and return @Just rhsName@ if this is the case + isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name + isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = [] + , m_grhss = grhss })])} + | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss + , EmptyLocalBinds _ <- unLoc lbinds + , HsVar _ lrhsName <- unLoc body = Just (unLoc lrhsName) + isAliasMG _ = Nothing + + -- got "lhs = rhs" but expected something different + addWarnNonCanonicalMethod1 flag lhs rhs = do + addWarn (Reason flag) $ vcat + [ text "Noncanonical" <+> + quotes (text (lhs ++ " = " ++ rhs)) <+> + text "definition detected" + , instDeclCtxt1 poly_ty + , text "Move definition from" <+> + quotes (text rhs) <+> + text "to" <+> quotes (text lhs) + ] + + -- expected "lhs = rhs" but got something else + addWarnNonCanonicalMethod2 flag lhs rhs = do + addWarn (Reason flag) $ vcat + [ text "Noncanonical" <+> + quotes (text lhs) <+> + text "definition detected" + , instDeclCtxt1 poly_ty + , text "Either remove definition for" <+> + quotes (text lhs) <+> text "or define as" <+> + quotes (text (lhs ++ " = " ++ rhs)) + ] + + -- like above, but method has no default impl + addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do + addWarn (Reason flag) $ vcat + [ text "Noncanonical" <+> + quotes (text lhs) <+> + text "definition detected" + , instDeclCtxt1 poly_ty + , text "Define as" <+> + quotes (text (lhs ++ " = " ++ rhs)) + ] + + -- stolen from TcInstDcls + instDeclCtxt1 :: LHsSigType GhcRn -> SDoc + instDeclCtxt1 hs_inst_ty + = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) + + inst_decl_ctxt :: SDoc -> SDoc + inst_decl_ctxt doc = hang (text "in the instance declaration for") + 2 (quotes doc <> text ".") + + +rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars) +rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds + , cid_sigs = uprags, cid_tyfam_insts = ats + , cid_overlap_mode = oflag + , cid_datafam_insts = adts }) + = do { (inst_ty', inst_fvs) + <- rnHsSigType (GenericCtx $ text "an instance declaration") TypeLevel inst_ty + ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' + ; cls <- + case hsTyGetAppHead_maybe head_ty' of + Just (L _ cls) -> pure cls + Nothing -> do + -- The instance is malformed. We'd still like + -- to make *some* progress (rather than failing outright), so + -- we report an error and continue for as long as we can. + -- Importantly, this error should be thrown before we reach the + -- typechecker, lest we encounter different errors that are + -- hopelessly confusing (such as the one in #16114). + addErrAt (getLoc (hsSigType inst_ty)) $ + hang (text "Illegal class instance:" <+> quotes (ppr inst_ty)) + 2 (vcat [ text "Class instances must be of the form" + , nest 2 $ text "context => C ty_1 ... ty_n" + , text "where" <+> quotes (char 'C') + <+> text "is a class" + ]) + pure $ mkUnboundName (mkTcOccFS (fsLit "<class>")) + + -- Rename the bindings + -- The typechecker (not the renamer) checks that all + -- the bindings are for the right class + -- (Slightly strangely) when scoped type variables are on, the + -- forall-d tyvars scope over the method bindings too + ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags + + ; checkCanonicalInstances cls inst_ty' mbinds' + + -- Rename the associated types, and type signatures + -- Both need to have the instance type variables in scope + ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names) + ; ((ats', adts'), more_fvs) + <- extendTyVarEnvFVRn ktv_names $ + do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats + ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts + ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) } + + ; let all_fvs = meth_fvs `plusFV` more_fvs + `plusFV` inst_fvs + ; return (ClsInstDecl { cid_ext = noExtField + , cid_poly_ty = inst_ty', cid_binds = mbinds' + , cid_sigs = uprags', cid_tyfam_insts = ats' + , cid_overlap_mode = oflag + , cid_datafam_insts = adts' }, + all_fvs) } + -- We return the renamed associated data type declarations so + -- that they can be entered into the list of type declarations + -- for the binding group, but we also keep a copy in the instance. + -- The latter is needed for well-formedness checks in the type + -- checker (eg, to ensure that all ATs of the instance actually + -- receive a declaration). + -- NB: Even the copies in the instance declaration carry copies of + -- the instance context after renaming. This is a bit + -- strange, but should not matter (and it would be more work + -- to remove the context). +rnClsInstDecl (XClsInstDecl nec) = noExtCon nec + +rnFamInstEqn :: HsDocContext + -> AssocTyFamInfo + -> [Located RdrName] -- Kind variables from the equation's RHS + -> FamInstEqn GhcPs rhs + -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) + -> RnM (FamInstEqn GhcRn rhs', FreeVars) +rnFamInstEqn doc atfi rhs_kvars + (HsIB { hsib_body = FamEqn { feqn_tycon = tycon + , feqn_bndrs = mb_bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = payload }}) rn_payload + = do { let mb_cls = case atfi of + NonAssocTyFamEqn -> Nothing + AssocTyFamDeflt cls -> Just cls + AssocTyFamInst cls _ -> Just cls + ; tycon' <- lookupFamInstName mb_cls tycon + ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats + -- Use the "...Dups" form because it's needed + -- below to report unused binder on the LHS + + -- Implicitly bound variables, empty if we have an explicit 'forall' according + -- to the "forall-or-nothing" rule. + ; let imp_vars | isNothing mb_bndrs = nubL pat_kity_vars_with_dups + | otherwise = [] + ; imp_var_names <- mapM (newTyVarNameRn mb_cls) imp_vars + + ; let bndrs = fromMaybe [] mb_bndrs + bnd_vars = map hsLTyVarLocName bndrs + payload_kvars = filterOut (`elemRdr` (bnd_vars ++ imp_vars)) rhs_kvars + -- Make sure to filter out the kind variables that were explicitly + -- bound in the type patterns. + ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars + + -- all names not bound in an explict forall + ; let all_imp_var_names = imp_var_names ++ payload_kvar_names + + -- All the free vars of the family patterns + -- with a sensible binding location + ; ((bndrs', pats', payload'), fvs) + <- bindLocalNamesFV all_imp_var_names $ + bindLHsTyVarBndrs doc (Just $ inHsDocContext doc) + Nothing bndrs $ \bndrs' -> + -- Note: If we pass mb_cls instead of Nothing here, + -- 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 class variables. + -- Thus: always pass Nothing + do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats + ; (payload', rhs_fvs) <- rn_payload doc payload + + -- Report unused binders on the LHS + -- See Note [Unused type variables in family instances] + ; let groups :: [NonEmpty (Located RdrName)] + groups = equivClasses cmpLocated $ + pat_kity_vars_with_dups + ; nms_dups <- mapM (lookupOccRn . unLoc) $ + [ tv | (tv :| (_:_)) <- groups ] + -- Add to the used variables + -- a) any variables that appear *more than once* on the LHS + -- e.g. F a Int a = Bool + -- b) for associated instances, the variables + -- of the instance decl. See + -- Note [Unused type variables in family instances] + ; let nms_used = extendNameSetList rhs_fvs $ + inst_tvs ++ nms_dups + inst_tvs = case atfi of + NonAssocTyFamEqn -> [] + AssocTyFamDeflt _ -> [] + AssocTyFamInst _ inst_tvs -> inst_tvs + all_nms = all_imp_var_names ++ hsLTyVarNames bndrs' + ; warnUnusedTypePatterns all_nms nms_used + + ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) } + + ; let all_fvs = fvs `addOneFV` unLoc tycon' + -- type instance => use, hence addOneFV + + ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances] + , hsib_body + = FamEqn { feqn_ext = noExtField + , feqn_tycon = tycon' + , feqn_bndrs = bndrs' <$ mb_bndrs + , feqn_pats = pats' + , feqn_fixity = fixity + , feqn_rhs = payload' } }, + all_fvs) } +rnFamInstEqn _ _ _ (HsIB _ (XFamEqn nec)) _ = noExtCon nec +rnFamInstEqn _ _ _ (XHsImplicitBndrs nec) _ = noExtCon nec + +rnTyFamInstDecl :: AssocTyFamInfo + -> TyFamInstDecl GhcPs + -> RnM (TyFamInstDecl GhcRn, FreeVars) +rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn }) + = do { (eqn', fvs) <- rnTyFamInstEqn atfi NotClosedTyFam eqn + ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) } + +-- | Tracks whether we are renaming: +-- +-- 1. A type family equation that is not associated +-- with a parent type class ('NonAssocTyFamEqn') +-- +-- 2. An associated type family default delcaration ('AssocTyFamDeflt') +-- +-- 3. An associated type family instance declaration ('AssocTyFamInst') +data AssocTyFamInfo + = NonAssocTyFamEqn + | AssocTyFamDeflt Name -- Name of the parent class + | AssocTyFamInst Name -- Name of the parent class + [Name] -- Names of the tyvars of the parent instance decl + +-- | Tracks whether we are renaming an equation in a closed type family +-- equation ('ClosedTyFam') or not ('NotClosedTyFam'). +data ClosedTyFamInfo + = NotClosedTyFam + | ClosedTyFam (Located RdrName) Name + -- The names (RdrName and Name) of the closed type family + +rnTyFamInstEqn :: AssocTyFamInfo + -> ClosedTyFamInfo + -> TyFamInstEqn GhcPs + -> RnM (TyFamInstEqn GhcRn, FreeVars) +rnTyFamInstEqn atfi ctf_info + eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon + , feqn_rhs = rhs }}) + = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs + ; (eqn'@(HsIB { hsib_body = + FamEqn { feqn_tycon = L _ tycon' }}), fvs) + <- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn + ; case ctf_info of + NotClosedTyFam -> pure () + ClosedTyFam fam_rdr_name fam_name -> + checkTc (fam_name == tycon') $ + withHsDocContext (TyFamilyCtx fam_rdr_name) $ + wrongTyFamName fam_name tycon' + ; pure (eqn', fvs) } +rnTyFamInstEqn _ _ (HsIB _ (XFamEqn nec)) = noExtCon nec +rnTyFamInstEqn _ _ (XHsImplicitBndrs nec) = noExtCon nec + +rnTyFamDefltDecl :: Name + -> TyFamDefltDecl GhcPs + -> RnM (TyFamDefltDecl GhcRn, FreeVars) +rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls) + +rnDataFamInstDecl :: AssocTyFamInfo + -> DataFamInstDecl GhcPs + -> RnM (DataFamInstDecl GhcRn, FreeVars) +rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body = + FamEqn { feqn_tycon = tycon + , feqn_rhs = rhs }})}) + = do { let rhs_kvs = extractDataDefnKindVars rhs + ; (eqn', fvs) <- + rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn + ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) } +rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn nec))) + = noExtCon nec +rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs nec)) + = noExtCon nec + +-- Renaming of the associated types in instances. + +-- Rename associated type family decl in class +rnATDecls :: Name -- Class + -> [LFamilyDecl GhcPs] + -> RnM ([LFamilyDecl GhcRn], FreeVars) +rnATDecls cls at_decls + = rnList (rnFamDecl (Just cls)) at_decls + +rnATInstDecls :: (AssocTyFamInfo -> -- The function that renames + decl GhcPs -> -- an instance. rnTyFamInstDecl + RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl + -> Name -- Class + -> [Name] + -> [Located (decl GhcPs)] + -> RnM ([Located (decl GhcRn)], FreeVars) +-- Used for data and type family defaults in a class decl +-- and the family instance declarations in an instance +-- +-- NB: We allow duplicate associated-type decls; +-- See Note [Associated type instances] in TcInstDcls +rnATInstDecls rnFun cls tv_ns at_insts + = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts + -- See Note [Renaming associated types] + +{- Note [Wildcards in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Wild cards can be used in type/data family instance declarations to indicate +that the name of a type variable doesn't matter. Each wild card will be +replaced with a new unique type variable. For instance: + + type family F a b :: * + type instance F Int _ = Int + +is the same as + + type family F a b :: * + type instance F Int b = Int + +This is implemented as follows: Unnamed wildcards remain unchanged after +the renamer, and then given fresh meta-variables during typechecking, and +it is handled pretty much the same way as the ones in partial type signatures. +We however don't want to emit hole constraints on wildcards in family +instances, so we turn on PartialTypeSignatures and turn off warning flag to +let typechecker know this. +See related Note [Wildcards in visible kind application] in TcHsType.hs + +Note [Unused type variables in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the flag -fwarn-unused-type-patterns is on, the compiler reports +warnings about unused type variables in type-family instances. A +tpye variable is considered used (i.e. cannot be turned into a wildcard) +when + + * it occurs on the RHS of the family instance + e.g. type instance F a b = a -- a is used on the RHS + + * it occurs multiple times in the patterns on the LHS + e.g. type instance F a a = Int -- a appears more than once on LHS + + * it is one of the instance-decl variables, for associated types + e.g. instance C (a,b) where + type T (a,b) = a + Here the type pattern in the type instance must be the same as that + for the class instance, so + type T (a,_) = a + would be rejected. So we should not complain about an unused variable b + +As usual, the warnings are not reported for type variables with names +beginning with an underscore. + +Extra-constraints wild cards are not supported in type/data family +instance declarations. + +Relevant tickets: #3699, #10586, #10982 and #11451. + +Note [Renaming associated types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Check that the RHS of the decl mentions only type variables that are explicitly +bound on the LHS. For example, this is not ok + class C a b where + type F a x :: * + instance C (p,q) r where + type F (p,q) x = (x, r) -- BAD: mentions 'r' +c.f. #5515 + +Kind variables, on the other hand, are allowed to be implicitly or explicitly +bound. As examples, this (#9574) is acceptable: + class Funct f where + type Codomain f :: * + instance Funct ('KProxy :: KProxy o) where + -- o is implicitly bound by the kind signature + -- of the LHS type pattern ('KProxy) + type Codomain 'KProxy = NatTr (Proxy :: o -> *) +And this (#14131) is also acceptable: + data family Nat :: k -> k -> * + -- k is implicitly bound by an invisible kind pattern + newtype instance Nat :: (k -> *) -> (k -> *) -> * where + Nat :: (forall xx. f xx -> g xx) -> Nat f g +We could choose to disallow this, but then associated type families would not +be able to be as expressive as top-level type synonyms. For example, this type +synonym definition is allowed: + type T = (Nothing :: Maybe a) +So for parity with type synonyms, we also allow: + type family T :: Maybe a + type instance T = (Nothing :: Maybe a) + +All this applies only for *instance* declarations. In *class* +declarations there is no RHS to worry about, and the class variables +can all be in scope (#5862): + class Category (x :: k -> k -> *) where + type Ob x :: k -> Constraint + id :: Ob x a => x a a + (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c +Here 'k' is in scope in the kind signature, just like 'x'. + +Although type family equations can bind type variables with explicit foralls, +it need not be the case that all variables that appear on the RHS must be bound +by a forall. For instance, the following is acceptable: + + class C a where + type T a b + instance C (Maybe a) where + type forall b. T (Maybe a) b = Either a b + +Even though `a` is not bound by the forall, this is still accepted because `a` +was previously bound by the `instance C (Maybe a)` part. (see #16116). + +In each case, the function which detects improperly bound variables on the RHS +is TcValidity.checkValidFamPats. +-} + + +{- +********************************************************* +* * +\subsection{Stand-alone deriving declarations} +* * +********************************************************* +-} + +rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars) +rnSrcDerivDecl (DerivDecl _ ty mds overlap) + = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving + ; unless standalone_deriv_ok (addErr standaloneDerivErr) + ; (mds', ty', fvs) + <- rnLDerivStrategy DerivDeclCtx mds $ + rnHsSigWcType BindUnlessForall DerivDeclCtx ty + ; warnNoDerivStrat mds' loc + ; return (DerivDecl noExtField ty' mds' overlap, fvs) } + where + loc = getLoc $ hsib_body $ hswc_body ty +rnSrcDerivDecl (XDerivDecl nec) = noExtCon nec + +standaloneDerivErr :: SDoc +standaloneDerivErr + = hang (text "Illegal standalone deriving declaration") + 2 (text "Use StandaloneDeriving to enable this extension") + +{- +********************************************************* +* * +\subsection{Rules} +* * +********************************************************* +-} + +rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars) +rnHsRuleDecls (HsRules { rds_src = src + , rds_rules = rules }) + = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules + ; return (HsRules { rds_ext = noExtField + , rds_src = src + , rds_rules = rn_rules }, fvs) } +rnHsRuleDecls (XRuleDecls nec) = noExtCon nec + +rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars) +rnHsRuleDecl (HsRule { rd_name = rule_name + , rd_act = act + , rd_tyvs = tyvs + , rd_tmvs = tmvs + , rd_lhs = lhs + , rd_rhs = rhs }) + = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs + ; checkDupRdrNames rdr_names_w_loc + ; checkShadowedRdrNames rdr_names_w_loc + ; names <- newLocalBndrsRn rdr_names_w_loc + ; let doc = RuleCtx (snd $ unLoc rule_name) + ; bindRuleTyVars doc in_rule tyvs $ \ tyvs' -> + bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' -> + do { (lhs', fv_lhs') <- rnLExpr lhs + ; (rhs', fv_rhs') <- rnLExpr rhs + ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs' + ; return (HsRule { rd_ext = HsRuleRn fv_lhs' fv_rhs' + , rd_name = rule_name + , rd_act = act + , rd_tyvs = tyvs' + , rd_tmvs = tmvs' + , rd_lhs = lhs' + , rd_rhs = rhs' }, fv_lhs' `plusFV` fv_rhs') } } + where + get_var (RuleBndrSig _ v _) = v + get_var (RuleBndr _ v) = v + get_var (XRuleBndr nec) = noExtCon nec + in_rule = text "in the rule" <+> pprFullRuleName rule_name +rnHsRuleDecl (XRuleDecl nec) = noExtCon nec + +bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs + -> [LRuleBndr GhcPs] -> [Name] + -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindRuleTmVars doc tyvs vars names thing_inside + = go vars names $ \ vars' -> + bindLocalNamesFV names (thing_inside vars') + where + go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside + = go vars ns $ \ vars' -> + thing_inside (L l (RuleBndr noExtField (L loc n)) : vars') + + go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars) + (n : ns) thing_inside + = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' -> + go vars ns $ \ vars' -> + thing_inside (L l (RuleBndrSig noExtField (L loc n) bsig') : vars') + + go [] [] thing_inside = thing_inside [] + go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) + + bind_free_tvs = case tyvs of Nothing -> AlwaysBind + Just _ -> NeverBind + +bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs] + -> (Maybe [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +bindRuleTyVars doc in_doc (Just bndrs) thing_inside + = bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just) +bindRuleTyVars _ _ _ thing_inside = thing_inside Nothing + +{- +Note [Rule LHS validity checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Check the shape of a transformation rule LHS. Currently we only allow +LHSs of the form @(f e1 .. en)@, where @f@ is not one of the +@forall@'d variables. + +We used restrict the form of the 'ei' to prevent you writing rules +with LHSs with a complicated desugaring (and hence unlikely to match); +(e.g. a case expression is not allowed: too elaborate.) + +But there are legitimate non-trivial args ei, like sections and +lambdas. So it seems simmpler not to check at all, and that is why +check_e is commented out. +-} + +checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM () +checkValidRule rule_name ids lhs' fv_lhs' + = do { -- Check for the form of the LHS + case (validRuleLhs ids lhs') of + Nothing -> return () + Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad) + + -- Check that LHS vars are all bound + ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] + ; mapM_ (addErr . badRuleVar rule_name) bad_vars } + +validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn) +-- Nothing => OK +-- Just e => Not ok, and e is the offending sub-expression +validRuleLhs foralls lhs + = checkl lhs + where + checkl = check . unLoc + + check (OpApp _ e1 op e2) = checkl op `mplus` checkl_e e1 + `mplus` checkl_e e2 + check (HsApp _ e1 e2) = checkl e1 `mplus` checkl_e e2 + check (HsAppType _ e _) = checkl e + check (HsVar _ lv) + | (unLoc lv) `notElem` foralls = Nothing + check other = Just other -- Failure + + -- Check an argument + checkl_e _ = Nothing + -- Was (check_e e); see Note [Rule LHS validity checking] + +{- Commented out; see Note [Rule LHS validity checking] above + check_e (HsVar v) = Nothing + check_e (HsPar e) = checkl_e e + check_e (HsLit e) = Nothing + check_e (HsOverLit e) = Nothing + + check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2 + check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2 + check_e (NegApp e _) = checkl_e e + check_e (ExplicitList _ es) = checkl_es es + check_e other = Just other -- Fails + + checkl_es es = foldr (mplus . checkl_e) Nothing es +-} + +badRuleVar :: FastString -> Name -> SDoc +badRuleVar name var + = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon, + text "Forall'd variable" <+> quotes (ppr var) <+> + text "does not appear on left hand side"] + +badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc +badRuleLhsErr name lhs bad_e + = sep [text "Rule" <+> pprRuleName name <> colon, + nest 2 (vcat [err, + text "in left-hand side:" <+> ppr lhs])] + $$ + text "LHS must be of form (f e1 .. en) where f is not forall'd" + where + err = case bad_e of + HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual uv) + _ -> text "Illegal expression:" <+> ppr bad_e + +{- ************************************************************** + * * + Renaming type, class, instance and role declarations +* * +***************************************************************** + +@rnTyDecl@ uses the `global name function' to create a new type +declaration in which local names have been replaced by their original +names, reporting any unknown names. + +Renaming type variables is a pain. Because they now contain uniques, +it is necessary to pass in an association list which maps a parsed +tyvar to its @Name@ representation. +In some cases (type signatures of values), +it is even necessary to go over the type first +in order to get the set of tyvars used by it, make an assoc list, +and then go over it again to rename the tyvars! +However, we can also do some scoping checks at the same time. + +Note [Dependency analysis of type, class, and instance decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A TyClGroup represents a strongly connected components of +type/class/instance decls, together with the role annotations for the +type/class declarations. The renamer uses strongly connected +comoponent analysis to build these groups. We do this for a number of +reasons: + +* Improve kind error messages. Consider + + data T f a = MkT f a + data S f a = MkS f (T f a) + + This has a kind error, but the error message is better if you + check T first, (fixing its kind) and *then* S. If you do kind + inference together, you might get an error reported in S, which + is jolly confusing. See #4875 + + +* Increase kind polymorphism. See TcTyClsDecls + Note [Grouping of type and class declarations] + +Why do the instance declarations participate? At least two reasons + +* Consider (#11348) + + type family F a + type instance F Int = Bool + + data R = MkR (F Int) + + type Foo = 'MkR 'True + + For Foo to kind-check we need to know that (F Int) ~ Bool. But we won't + know that unless we've looked at the type instance declaration for F + before kind-checking Foo. + +* Another example is this (#3990). + + data family Complex a + data instance Complex Double = CD {-# UNPACK #-} !Double + {-# UNPACK #-} !Double + + data T = T {-# UNPACK #-} !(Complex Double) + + Here, to generate the right kind of unpacked implementation for T, + we must have access to the 'data instance' declaration. + +* Things become more complicated when we introduce transitive + dependencies through imported definitions, like in this scenario: + + A.hs + type family Closed (t :: Type) :: Type where + Closed t = Open t + + type family Open (t :: Type) :: Type + + B.hs + data Q where + Q :: Closed Bool -> Q + + type instance Open Int = Bool + + type S = 'Q 'True + + Somehow, we must ensure that the instance Open Int = Bool is checked before + the type synonym S. While we know that S depends upon 'Q depends upon Closed, + we have no idea that Closed depends upon Open! + + To accommodate for these situations, we ensure that an instance is checked + before every @TyClDecl@ on which it does not depend. That's to say, instances + are checked as early as possible in @tcTyAndClassDecls@. + +------------------------------------ +So much for WHY. What about HOW? It's pretty easy: + +(1) Rename the type/class, instance, and role declarations + individually + +(2) Do strongly-connected component analysis of the type/class decls, + We'll make a TyClGroup for each SCC + + In this step we treat a reference to a (promoted) data constructor + K as a dependency on its parent type. Thus + data T = K1 | K2 + data S = MkS (Proxy 'K1) + Here S depends on 'K1 and hence on its parent T. + + In this step we ignore instances; see + Note [No dependencies on data instances] + +(3) Attach roles to the appropriate SCC + +(4) Attach instances to the appropriate SCC. + We add an instance decl to SCC when: + all its free types/classes are bound in this SCC or earlier ones + +(5) We make an initial TyClGroup, with empty group_tyclds, for any + (orphan) instances that affect only imported types/classes + +Steps (3) and (4) are done by the (mapAccumL mk_group) call. + +Note [No dependencies on data instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + data family D a + data instance D Int = D1 + data S = MkS (Proxy 'D1) + +Here the declaration of S depends on the /data instance/ declaration +for 'D Int'. That makes things a lot more complicated, especially +if the data instance is an associated type of an enclosing class instance. +(And the class instance might have several associated type instances +with different dependency structure!) + +Ugh. For now we simply don't allow promotion of data constructors for +data instances. See Note [AFamDataCon: not promoting data family +constructors] in TcEnv +-} + + +rnTyClDecls :: [TyClGroup GhcPs] + -> RnM ([TyClGroup GhcRn], FreeVars) +-- Rename the declarations and do dependency analysis on them +rnTyClDecls tycl_ds + = do { -- Rename the type/class, instance, and role declaraations + ; tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupTyClDecls tycl_ds) + ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs) + ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds) + ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds) + ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds) + + -- Do SCC analysis on the type/class decls + ; rdr_env <- getGlobalRdrEnv + ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs + role_annot_env = mkRoleAnnotEnv role_annots + (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs + + inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs + (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map + + first_group + | null init_inst_ds = [] + | otherwise = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [] + , group_roles = [] + , group_instds = init_inst_ds }] + + (final_inst_ds, groups) + = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs + + all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs `plusFV` + foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV` + foldr (plusFV . snd) emptyFVs kisigs_w_fvs + + all_groups = first_group ++ groups + + ; MASSERT2( null final_inst_ds, ppr instds_w_fvs $$ ppr inst_ds_map + $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds ) + + ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups) + ; return (all_groups, all_fvs) } + where + mk_group :: RoleAnnotEnv + -> KindSigEnv + -> InstDeclFreeVarsMap + -> SCC (LTyClDecl GhcRn) + -> (InstDeclFreeVarsMap, TyClGroup GhcRn) + mk_group role_env kisig_env inst_map scc + = (inst_map', group) + where + tycl_ds = flattenSCC scc + bndrs = map (tcdName . unLoc) tycl_ds + roles = getRoleAnnots bndrs role_env + kisigs = getKindSigs bndrs kisig_env + (inst_ds, inst_map') = getInsts bndrs inst_map + group = TyClGroup { group_ext = noExtField + , group_tyclds = tycl_ds + , group_kisigs = kisigs + , group_roles = roles + , group_instds = inst_ds } + +-- | Free variables of standalone kind signatures. +newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars) + +lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars +lookupKindSig_FV_Env (KindSig_FV_Env e) name + = fromMaybe emptyFVs (lookupNameEnv e name) + +-- | Standalone kind signatures. +type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn) + +mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env) +mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env) + where + kisig_env = mapNameEnv fst compound_env + kisig_fv_env = KindSig_FV_Env (mapNameEnv snd compound_env) + compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars) + = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs + +getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn] +getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs + +rnStandaloneKindSignatures + :: NameSet -- names of types and classes in the current TyClGroup + -> [LStandaloneKindSig GhcPs] + -> RnM [(LStandaloneKindSig GhcRn, FreeVars)] +rnStandaloneKindSignatures tc_names kisigs + = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs + get_name = standaloneKindSigName . unLoc + ; mapM_ dupKindSig_Err dup_kisigs + ; mapM (wrapLocFstM (rnStandaloneKindSignature tc_names)) no_dups + } + +rnStandaloneKindSignature + :: NameSet -- names of types and classes in the current TyClGroup + -> StandaloneKindSig GhcPs + -> RnM (StandaloneKindSig GhcRn, FreeVars) +rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki) + = do { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures + ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr + ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v + ; let doc = StandaloneKindSigCtx (ppr v) + ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki + ; return (StandaloneKindSig noExtField new_v new_ki, fvs) + } + where + standaloneKiSigErr :: SDoc + standaloneKiSigErr = + hang (text "Illegal standalone kind signature") + 2 (text "Did you mean to enable StandaloneKindSignatures?") +rnStandaloneKindSignature _ (XStandaloneKindSig nec) = noExtCon nec + +depAnalTyClDecls :: GlobalRdrEnv + -> KindSig_FV_Env + -> [(LTyClDecl GhcRn, FreeVars)] + -> [SCC (LTyClDecl GhcRn)] +-- See Note [Dependency analysis of type, class, and instance decls] +depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs + = stronglyConnCompFromEdgedVerticesUniq edges + where + edges :: [ Node Name (LTyClDecl GhcRn) ] + edges = [ DigraphNode d name (map (getParent rdr_env) (nonDetEltsUniqSet deps)) + | (d, fvs) <- ds_w_fvs, + let { name = tcdName (unLoc d) + ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name + ; deps = fvs `plusFV` kisig_fvs + } + ] + -- It's OK to use nonDetEltsUFM here as + -- stronglyConnCompFromEdgedVertices is still deterministic + -- even if the edges are in nondeterministic order as explained + -- in Note [Deterministic SCC] in Digraph. + +toParents :: GlobalRdrEnv -> NameSet -> NameSet +toParents rdr_env ns + = nonDetFoldUniqSet add emptyNameSet ns + -- It's OK to use nonDetFoldUFM because we immediately forget the + -- ordering by creating a set + where + add n s = extendNameSet s (getParent rdr_env n) + +getParent :: GlobalRdrEnv -> Name -> Name +getParent rdr_env n + = case lookupGRE_Name rdr_env n of + Just gre -> case gre_par gre of + ParentIs { par_is = p } -> p + FldParent { par_is = p } -> p + _ -> n + Nothing -> n + + +{- ****************************************************** +* * + Role annotations +* * +****************************************************** -} + +-- | Renames role annotations, returning them as the values in a NameEnv +-- and checks for duplicate role annotations. +-- It is quite convenient to do both of these in the same place. +-- See also Note [Role annotations in the renamer] +rnRoleAnnots :: NameSet + -> [LRoleAnnotDecl GhcPs] + -> RnM [LRoleAnnotDecl GhcRn] +rnRoleAnnots tc_names role_annots + = do { -- Check for duplicates *before* renaming, to avoid + -- lumping together all the unboundNames + let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots + get_name = roleAnnotDeclName . unLoc + ; mapM_ dupRoleAnnotErr dup_annots + ; mapM (wrapLocM rn_role_annot1) no_dups } + where + rn_role_annot1 (RoleAnnotDecl _ tycon roles) + = do { -- the name is an *occurrence*, but look it up only in the + -- decls defined in this group (see #10263) + tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names) + (text "role annotation") + tycon + ; return $ RoleAnnotDecl noExtField tycon' roles } + rn_role_annot1 (XRoleAnnotDecl nec) = noExtCon nec + +dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () +dupRoleAnnotErr list + = addErrAt loc $ + hang (text "Duplicate role annotations for" <+> + quotes (ppr $ roleAnnotDeclName first_decl) <> colon) + 2 (vcat $ map pp_role_annot $ NE.toList sorted_list) + where + sorted_list = NE.sortBy cmp_annot list + ((L loc first_decl) :| _) = sorted_list + + pp_role_annot (L loc decl) = hang (ppr decl) + 4 (text "-- written at" <+> ppr loc) + + cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2 + +dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () +dupKindSig_Err list + = addErrAt loc $ + hang (text "Duplicate standalone kind signatures for" <+> + quotes (ppr $ standaloneKindSigName first_decl) <> colon) + 2 (vcat $ map pp_kisig $ NE.toList sorted_list) + where + sorted_list = NE.sortBy cmp_loc list + ((L loc first_decl) :| _) = sorted_list + + pp_kisig (L loc decl) = + hang (ppr decl) 4 (text "-- written at" <+> ppr loc) + + cmp_loc (L loc1 _) (L loc2 _) = loc1 `compare` loc2 + +{- Note [Role annotations in the renamer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We must ensure that a type's role annotation is put in the same group as the +proper type declaration. This is because role annotations are needed during +type-checking when creating the type's TyCon. So, rnRoleAnnots builds a +NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that +type, if any. Then, this map can be used to add the role annotations to the +groups after dependency analysis. + +This process checks for duplicate role annotations, where we must be careful +to do the check *before* renaming to avoid calling all unbound names duplicates +of one another. + +The renaming process, as usual, might identify and report errors for unbound +names. This is done by using lookupSigCtxtOccRn in rnRoleAnnots (using +lookupGlobalOccRn led to #8485). +-} + + +{- ****************************************************** +* * + Dependency info for instances +* * +****************************************************** -} + +---------------------------------------------------------- +-- | 'InstDeclFreeVarsMap is an association of an +-- @InstDecl@ with @FreeVars@. The @FreeVars@ are +-- the tycon names that are both +-- a) free in the instance declaration +-- b) bound by this group of type/class/instance decls +type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)] + +-- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the +-- @FreeVars@ which are *not* the binders of a @TyClDecl@. +mkInstDeclFreeVarsMap :: GlobalRdrEnv + -> NameSet + -> [(LInstDecl GhcRn, FreeVars)] + -> InstDeclFreeVarsMap +mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs + = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs) + | (inst_decl, fvs) <- inst_ds_fvs ] + +-- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the +-- @InstDeclFreeVarsMap@ with these entries removed. +-- We call (getInsts tcs instd_map) when we've completed the declarations +-- for 'tcs'. The call returns (inst_decls, instd_map'), where +-- inst_decls are the instance declarations all of +-- whose free vars are now defined +-- instd_map' is the inst-decl map with 'tcs' removed from +-- the free-var set +getInsts :: [Name] -> InstDeclFreeVarsMap + -> ([LInstDecl GhcRn], InstDeclFreeVarsMap) +getInsts bndrs inst_decl_map + = partitionWith pick_me inst_decl_map + where + pick_me :: (LInstDecl GhcRn, FreeVars) + -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars) + pick_me (decl, fvs) + | isEmptyNameSet depleted_fvs = Left decl + | otherwise = Right (decl, depleted_fvs) + where + depleted_fvs = delFVs bndrs fvs + +{- ****************************************************** +* * + Renaming a type or class declaration +* * +****************************************************** -} + +rnTyClDecl :: TyClDecl GhcPs + -> RnM (TyClDecl GhcRn, FreeVars) + +-- All flavours of top-level type family declarations ("type family", "newtype +-- family", and "data family") +rnTyClDecl (FamDecl { tcdFam = fam }) + = do { (fam', fvs) <- rnFamDecl Nothing fam + ; return (FamDecl noExtField fam', fvs) } + +rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, + tcdFixity = fixity, tcdRhs = rhs }) + = do { tycon' <- lookupLocatedTopBndrRn tycon + ; let kvs = extractHsTyRdrTyVarsKindVars rhs + doc = TySynCtx tycon + ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs) + ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> + do { (rhs', fvs) <- rnTySyn doc rhs + ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars' + , tcdFixity = fixity + , tcdRhs = rhs', tcdSExt = fvs }, fvs) } } + +-- "data", "newtype" declarations +rnTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec +rnTyClDecl (DataDecl + { tcdLName = tycon, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data + , dd_kindSig = kind_sig} }) + = do { tycon' <- lookupLocatedTopBndrRn tycon + ; let kvs = extractDataDefnKindVars defn + doc = TyDataCtx tycon + ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs) + ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs -> + do { (defn', fvs) <- rnDataDefn doc defn + ; cusk <- data_decl_has_cusk tyvars' new_or_data no_rhs_kvs kind_sig + ; let rn_info = DataDeclRn { tcdDataCusk = cusk + , tcdFVs = fvs } + ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs) + ; return (DataDecl { tcdLName = tycon' + , tcdTyVars = tyvars' + , tcdFixity = fixity + , tcdDataDefn = defn' + , tcdDExt = rn_info }, fvs) } } + +rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, + tcdTyVars = tyvars, tcdFixity = fixity, + tcdFDs = fds, tcdSigs = sigs, + tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, + tcdDocs = docs}) + = do { lcls' <- lookupLocatedTopBndrRn lcls + ; let cls' = unLoc lcls' + kvs = [] -- No scoped kind vars except those in + -- kind signatures on the tyvars + + -- Tyvars scope over superclass context and method signatures + ; ((tyvars', context', fds', ats'), stuff_fvs) + <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do + -- Checks for distinct tyvars + { (context', cxt_fvs) <- rnContext cls_doc context + ; fds' <- rnFds fds + -- The fundeps have no free variables + ; (ats', fv_ats) <- rnATDecls cls' ats + ; let fvs = cxt_fvs `plusFV` + fv_ats + ; return ((tyvars', context', fds', ats'), fvs) } + + ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltDecl cls') at_defs + + -- No need to check for duplicate associated type decls + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + + -- Check the signatures + -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). + ; let sig_rdr_names_w_locs = + [op | L _ (ClassOpSig _ False ops _) <- sigs + , op <- ops] + ; checkDupRdrNames sig_rdr_names_w_locs + -- Typechecker is responsible for checking that we only + -- give default-method bindings for things in this class. + -- The renamer *could* check this for class decls, but can't + -- for instance decls. + + -- The newLocals call is tiresome: given a generic class decl + -- class C a where + -- op :: a -> a + -- op {| x+y |} (Inl a) = ... + -- op {| x+y |} (Inr b) = ... + -- op {| a*b |} (a*b) = ... + -- we want to name both "x" tyvars with the same unique, so that they are + -- easy to group together in the typechecker. + ; (mbinds', sigs', meth_fvs) + <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs + -- No need to check for duplicate method signatures + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + -- and the methods are already in scope + + -- Haddock docs + ; docs' <- mapM (wrapLocM rnDocDecl) docs + + ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs + ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', + tcdTyVars = tyvars', tcdFixity = fixity, + tcdFDs = fds', tcdSigs = sigs', + tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', + tcdDocs = docs', tcdCExt = all_fvs }, + all_fvs ) } + where + cls_doc = ClassDeclCtx lcls + +rnTyClDecl (XTyClDecl nec) = noExtCon nec + +-- Does the data type declaration include a CUSK? +data_decl_has_cusk :: LHsQTyVars pass -> NewOrData -> Bool -> Maybe (LHsKind pass') -> RnM Bool +data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do + { -- See Note [Unlifted Newtypes and CUSKs], and for a broader + -- picture, see Note [Implementation of UnliftedNewtypes]. + ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes + ; let non_cusk_newtype + | NewType <- new_or_data = + unlifted_newtypes && isNothing kind_sig + | otherwise = False + -- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls + ; return $ hsTvbAllKinded tyvars && no_rhs_kvs && not non_cusk_newtype + } + +{- Note [Unlifted Newtypes and CUSKs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When unlifted newtypes are enabled, a newtype must have a kind signature +in order to be considered have a CUSK. This is because the flow of +kind inference works differently. Consider: + + newtype Foo = FooC Int + +When UnliftedNewtypes is disabled, we decide that Foo has kind +`TYPE 'LiftedRep` without looking inside the data constructor. So, we +can say that Foo has a CUSK. However, when UnliftedNewtypes is enabled, +we fill in the kind of Foo as a metavar that gets solved by unification +with the kind of the field inside FooC (that is, Int, whose kind is +`TYPE 'LiftedRep`). But since we have to look inside the data constructors +to figure out the kind signature of Foo, it does not have a CUSK. + +See Note [Implementation of UnliftedNewtypes] for where this fits in to +the broader picture of UnliftedNewtypes. +-} + +-- "type" and "type instance" declarations +rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) +rnTySyn doc rhs = rnLHsType doc rhs + +rnDataDefn :: HsDocContext -> HsDataDefn GhcPs + -> RnM (HsDataDefn GhcRn, FreeVars) +rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = context, dd_cons = condecls + , dd_kindSig = m_sig, dd_derivs = derivs }) + = do { checkTc (h98_style || null (unLoc context)) + (badGadtStupidTheta doc) + + ; (m_sig', sig_fvs) <- case m_sig of + Just sig -> first Just <$> rnLHsKind doc sig + Nothing -> return (Nothing, emptyFVs) + ; (context', fvs1) <- rnContext doc context + ; (derivs', fvs3) <- rn_derivs derivs + + -- For the constructor declarations, drop the LocalRdrEnv + -- in the GADT case, where the type variables in the declaration + -- do not scope over the constructor signatures + -- data T a where { T1 :: forall b. b-> b } + ; let { zap_lcl_env | h98_style = \ thing -> thing + | otherwise = setLocalRdrEnv emptyLocalRdrEnv } + ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls + -- No need to check for duplicate constructor decls + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + + ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` + con_fvs `plusFV` sig_fvs + ; return ( HsDataDefn { dd_ext = noExtField + , dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = context', dd_kindSig = m_sig' + , dd_cons = condecls' + , dd_derivs = derivs' } + , all_fvs ) + } + where + h98_style = case condecls of -- Note [Stupid theta] + (L _ (ConDeclGADT {})) : _ -> False + _ -> True + + rn_derivs (L loc ds) + = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies + ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok) + multipleDerivClausesErr + ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds + ; return (L loc ds', fvs) } +rnDataDefn _ (XHsDataDefn nec) = noExtCon nec + +warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) + -> SrcSpan + -> RnM () +warnNoDerivStrat mds loc + = do { dyn_flags <- getDynFlags + ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $ + case mds of + Nothing -> addWarnAt + (Reason Opt_WarnMissingDerivingStrategies) + loc + (if xopt LangExt.DerivingStrategies dyn_flags + then no_strat_warning + else no_strat_warning $+$ deriv_strat_nenabled + ) + _ -> pure () + } + where + no_strat_warning :: SDoc + no_strat_warning = text "No deriving strategy specified. Did you want stock" + <> text ", newtype, or anyclass?" + deriv_strat_nenabled :: SDoc + deriv_strat_nenabled = text "Use DerivingStrategies to specify a strategy." + +rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs + -> RnM (LHsDerivingClause GhcRn, FreeVars) +rnLHsDerivingClause doc + (L loc (HsDerivingClause + { deriv_clause_ext = noExtField + , deriv_clause_strategy = dcs + , deriv_clause_tys = L loc' dct })) + = do { (dcs', dct', fvs) + <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel) dct + ; warnNoDerivStrat dcs' loc + ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField + , deriv_clause_strategy = dcs' + , deriv_clause_tys = L loc' dct' }) + , fvs ) } +rnLHsDerivingClause _ (L _ (XHsDerivingClause nec)) + = noExtCon nec + +rnLDerivStrategy :: forall a. + HsDocContext + -> Maybe (LDerivStrategy GhcPs) + -> RnM (a, FreeVars) + -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars) +rnLDerivStrategy doc mds thing_inside + = case mds of + Nothing -> boring_case Nothing + Just (L loc ds) -> + setSrcSpan loc $ do + (ds', thing, fvs) <- rn_deriv_strat ds + pure (Just (L loc ds'), thing, fvs) + where + rn_deriv_strat :: DerivStrategy GhcPs + -> RnM (DerivStrategy GhcRn, a, FreeVars) + rn_deriv_strat ds = do + let extNeeded :: LangExt.Extension + extNeeded + | ViaStrategy{} <- ds + = LangExt.DerivingVia + | otherwise + = LangExt.DerivingStrategies + + unlessXOptM extNeeded $ + failWith $ illegalDerivStrategyErr ds + + case ds of + StockStrategy -> boring_case StockStrategy + AnyclassStrategy -> boring_case AnyclassStrategy + NewtypeStrategy -> boring_case NewtypeStrategy + ViaStrategy via_ty -> + do (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty + let HsIB { hsib_ext = via_imp_tvs + , hsib_body = via_body } = via_ty' + (via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body + via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs + via_tvs = via_imp_tvs ++ via_exp_tvs + (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside + pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2) + + boring_case :: ds -> RnM (ds, a, FreeVars) + boring_case ds = do + (thing, fvs) <- thing_inside + pure (ds, thing, fvs) + +badGadtStupidTheta :: HsDocContext -> SDoc +badGadtStupidTheta _ + = vcat [text "No context is allowed on a GADT-style data declaration", + text "(You can put a context on each constructor, though.)"] + +illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc +illegalDerivStrategyErr ds + = vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds + , text enableStrategy ] + + where + enableStrategy :: String + enableStrategy + | ViaStrategy{} <- ds + = "Use DerivingVia to enable this extension" + | otherwise + = "Use DerivingStrategies to enable this extension" + +multipleDerivClausesErr :: SDoc +multipleDerivClausesErr + = vcat [ text "Illegal use of multiple, consecutive deriving clauses" + , text "Use DerivingStrategies to allow this" ] + +rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested + -- inside an *class decl* for cls + -- used for associated types + -> FamilyDecl GhcPs + -> RnM (FamilyDecl GhcRn, FreeVars) +rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars + , fdFixity = fixity + , fdInfo = info, fdResultSig = res_sig + , fdInjectivityAnn = injectivity }) + = do { tycon' <- lookupLocatedTopBndrRn tycon + ; ((tyvars', res_sig', injectivity'), fv1) <- + bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ -> + do { let rn_sig = rnFamResultSig doc + ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig + ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig') + injectivity + ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } + ; (info', fv2) <- rn_info tycon' info + ; return (FamilyDecl { fdExt = noExtField + , fdLName = tycon', fdTyVars = tyvars' + , fdFixity = fixity + , fdInfo = info', fdResultSig = res_sig' + , fdInjectivityAnn = injectivity' } + , fv1 `plusFV` fv2) } + where + doc = TyFamilyCtx tycon + kvs = extractRdrKindSigVars res_sig + + ---------------------- + rn_info :: Located Name + -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars) + rn_info (L _ fam_name) (ClosedTypeFamily (Just eqns)) + = do { (eqns', fvs) + <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name)) + -- no class context + eqns + ; return (ClosedTypeFamily (Just eqns'), fvs) } + rn_info _ (ClosedTypeFamily Nothing) + = return (ClosedTypeFamily Nothing, emptyFVs) + rn_info _ OpenTypeFamily = return (OpenTypeFamily, emptyFVs) + rn_info _ DataFamily = return (DataFamily, emptyFVs) +rnFamDecl _ (XFamilyDecl nec) = noExtCon nec + +rnFamResultSig :: HsDocContext + -> FamilyResultSig GhcPs + -> RnM (FamilyResultSig GhcRn, FreeVars) +rnFamResultSig _ (NoSig _) + = return (NoSig noExtField, emptyFVs) +rnFamResultSig doc (KindSig _ kind) + = do { (rndKind, ftvs) <- rnLHsKind doc kind + ; return (KindSig noExtField rndKind, ftvs) } +rnFamResultSig doc (TyVarSig _ tvbndr) + = do { -- `TyVarSig` tells us that user named the result of a type family by + -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to + -- be sure that the supplied result name is not identical to an + -- already in-scope type variable from an enclosing class. + -- + -- Example of disallowed declaration: + -- class C a b where + -- type F b = a | a -> b + rdr_env <- getLocalRdrEnv + ; let resName = hsLTyVarName tvbndr + ; when (resName `elemLocalRdrEnv` rdr_env) $ + addErrAt (getLoc tvbndr) $ + (hsep [ text "Type variable", quotes (ppr resName) <> comma + , text "naming a type family result," + ] $$ + text "shadows an already bound type variable") + + ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for + -- scoping checks that are irrelevant here + tvbndr $ \ tvbndr' -> + return (TyVarSig noExtField tvbndr', unitFV (hsLTyVarName tvbndr')) } +rnFamResultSig _ (XFamilyResultSig nec) = noExtCon nec + +-- Note [Renaming injectivity annotation] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- During renaming of injectivity annotation we have to make several checks to +-- make sure that it is well-formed. At the moment injectivity annotation +-- consists of a single injectivity condition, so the terms "injectivity +-- annotation" and "injectivity condition" might be used interchangeably. See +-- Note [Injectivity annotation] for a detailed discussion of currently allowed +-- injectivity annotations. +-- +-- Checking LHS is simple because the only type variable allowed on the LHS of +-- injectivity condition is the variable naming the result in type family head. +-- Example of disallowed annotation: +-- +-- type family Foo a b = r | b -> a +-- +-- Verifying RHS of injectivity consists of checking that: +-- +-- 1. only variables defined in type family head appear on the RHS (kind +-- variables are also allowed). Example of disallowed annotation: +-- +-- type family Foo a = r | r -> b +-- +-- 2. for associated types the result variable does not shadow any of type +-- class variables. Example of disallowed annotation: +-- +-- class Foo a b where +-- type F a = b | b -> a +-- +-- Breaking any of these assumptions results in an error. + +-- | Rename injectivity annotation. Note that injectivity annotation is just the +-- part after the "|". Everything that appears before it is renamed in +-- rnFamDecl. +rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in + -- type family head + -> LFamilyResultSig GhcRn -- ^ Result signature + -> LInjectivityAnn GhcPs -- ^ Injectivity annotation + -> RnM (LInjectivityAnn GhcRn) +rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) + (L srcSpan (InjectivityAnn injFrom injTo)) + = do + { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors) + <- askNoErrs $ + bindLocalNames [hsLTyVarName resTv] $ + -- The return type variable scopes over the injectivity annotation + -- e.g. type family F a = (r::*) | r -> a + do { injFrom' <- rnLTyVar injFrom + ; injTo' <- mapM rnLTyVar injTo + ; return $ L srcSpan (InjectivityAnn injFrom' injTo') } + + ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs + resName = hsLTyVarName resTv + -- See Note [Renaming injectivity annotation] + lhsValid = EQ == (stableNameCmp resName (unLoc injFrom')) + rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames + + -- if renaming of type variables ended with errors (eg. there were + -- not-in-scope variables) don't check the validity of injectivity + -- annotation. This gives better error messages. + ; when (noRnErrors && not lhsValid) $ + addErrAt (getLoc injFrom) + ( vcat [ text $ "Incorrect type variable on the LHS of " + ++ "injectivity condition" + , nest 5 + ( vcat [ text "Expected :" <+> ppr resName + , text "Actual :" <+> ppr injFrom ])]) + + ; when (noRnErrors && not (Set.null rhsValid)) $ + do { let errorVars = Set.toList rhsValid + ; addErrAt srcSpan $ ( hsep + [ text "Unknown type variable" <> plural errorVars + , text "on the RHS of injectivity condition:" + , interpp'SP errorVars ] ) } + + ; return injDecl' } + +-- We can only hit this case when the user writes injectivity annotation without +-- naming the result: +-- +-- type family F a | result -> a +-- type family F a :: * | result -> a +-- +-- So we rename injectivity annotation like we normally would except that +-- this time we expect "result" to be reported not in scope by rnLTyVar. +rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) = + setSrcSpan srcSpan $ do + (injDecl', _) <- askNoErrs $ do + injFrom' <- rnLTyVar injFrom + injTo' <- mapM rnLTyVar injTo + return $ L srcSpan (InjectivityAnn injFrom' injTo') + return $ injDecl' + +{- +Note [Stupid theta] +~~~~~~~~~~~~~~~~~~~ +#3850 complains about a regression wrt 6.10 for + data Show a => T a +There is no reason not to allow the stupid theta if there are no data +constructors. It's still stupid, but does no harm, and I don't want +to cause programs to break unnecessarily (notably HList). So if there +are no data constructors we allow h98_style = True +-} + + +{- ***************************************************** +* * + Support code for type/data declarations +* * +***************************************************** -} + +--------------- +wrongTyFamName :: Name -> Name -> SDoc +wrongTyFamName fam_tc_name eqn_tc_name + = hang (text "Mismatched type name in type family instance.") + 2 (vcat [ text "Expected:" <+> ppr fam_tc_name + , text " Actual:" <+> ppr eqn_tc_name ]) + +----------------- +rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars) +rnConDecls = mapFvRn (wrapLocFstM rnConDecl) + +rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) +rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs + , con_mb_cxt = mcxt, con_args = args + , con_doc = mb_doc }) + = do { _ <- addLocM checkConName name + ; new_name <- lookupLocatedTopBndrRn name + ; mb_doc' <- rnMbLHsDoc mb_doc + + -- We bind no implicit binders here; this is just like + -- a nested HsForAllTy. E.g. consider + -- data T a = forall (b::k). MkT (...) + -- The 'k' will already be in scope from the bindHsQTyVars + -- for the data decl itself. So we'll get + -- data T {k} a = ... + -- And indeed we may later discover (a::k). But that's the + -- scoping we get. So no implicit binders at the existential forall + + ; let ctxt = ConDeclCtx [new_name] + ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt)) + Nothing ex_tvs $ \ new_ex_tvs -> + do { (new_context, fvs1) <- rnMbContext ctxt mcxt + ; (new_args, fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args + ; let all_fvs = fvs1 `plusFV` fvs2 + ; traceRn "rnConDecl" (ppr name <+> vcat + [ text "ex_tvs:" <+> ppr ex_tvs + , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) + + ; return (decl { con_ext = noExtField + , con_name = new_name, con_ex_tvs = new_ex_tvs + , con_mb_cxt = new_context, con_args = new_args + , con_doc = mb_doc' }, + all_fvs) }} + +rnConDecl decl@(ConDeclGADT { con_names = names + , con_forall = L _ explicit_forall + , con_qvars = qtvs + , con_mb_cxt = mcxt + , con_args = args + , con_res_ty = res_ty + , con_doc = mb_doc }) + = do { mapM_ (addLocM checkConName) names + ; new_names <- mapM lookupLocatedTopBndrRn names + ; mb_doc' <- rnMbLHsDoc mb_doc + + ; let explicit_tkvs = hsQTvExplicit qtvs + theta = hsConDeclTheta mcxt + arg_tys = hsConDeclArgTys args + + -- We must ensure that we extract the free tkvs in left-to-right + -- order of their appearance in the constructor type. + -- That order governs the order the implicitly-quantified type + -- variable, and hence the order needed for visible type application + -- See #14808. + free_tkvs = extractHsTvBndrs explicit_tkvs $ + extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty]) + + ctxt = ConDeclCtx new_names + mb_ctxt = Just (inHsDocContext ctxt) + + ; traceRn "rnConDecl" (ppr names $$ ppr free_tkvs $$ ppr explicit_forall ) + ; rnImplicitBndrs (not explicit_forall) free_tkvs $ \ implicit_tkvs -> + bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs -> + do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt + ; (new_args, fvs2) <- rnConDeclDetails (unLoc (head new_names)) ctxt args + ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty + + ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 + (args', res_ty') + = case args of + InfixCon {} -> pprPanic "rnConDecl" (ppr names) + RecCon {} -> (new_args, new_res_ty) + PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty + -> ASSERT( null as ) + -- See Note [GADT abstract syntax] in GHC.Hs.Decls + (PrefixCon arg_tys, final_res_ty) + + new_qtvs = HsQTvs { hsq_ext = implicit_tkvs + , hsq_explicit = explicit_tkvs } + + ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs) + ; return (decl { con_g_ext = noExtField, con_names = new_names + , con_qvars = new_qtvs, con_mb_cxt = new_cxt + , con_args = args', con_res_ty = res_ty' + , con_doc = mb_doc' }, + all_fvs) } } + +rnConDecl (XConDecl nec) = noExtCon nec + + +rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs) + -> RnM (Maybe (LHsContext GhcRn), FreeVars) +rnMbContext _ Nothing = return (Nothing, emptyFVs) +rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt + ; return (Just ctx',fvs) } + +rnConDeclDetails + :: Name + -> HsDocContext + -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs]) + -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]), + FreeVars) +rnConDeclDetails _ doc (PrefixCon tys) + = do { (new_tys, fvs) <- rnLHsTypes doc tys + ; return (PrefixCon new_tys, fvs) } + +rnConDeclDetails _ doc (InfixCon ty1 ty2) + = do { (new_ty1, fvs1) <- rnLHsType doc ty1 + ; (new_ty2, fvs2) <- rnLHsType doc ty2 + ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } + +rnConDeclDetails con doc (RecCon (L l fields)) + = do { fls <- lookupConstructorFields con + ; (new_fields, fvs) <- rnConDeclFields doc fls fields + -- No need to check for duplicate fields + -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn + ; return (RecCon (L l new_fields), fvs) } + +------------------------------------------------- + +-- | Brings pattern synonym names and also pattern synonym selectors +-- from record pattern synonyms into scope. +extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv + -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a +extendPatSynEnv val_decls local_fix_env thing = do { + names_with_fls <- new_ps val_decls + ; let pat_syn_bndrs = concat [ name: map flSelector fields + | (name, fields) <- names_with_fls ] + ; let avails = map avail pat_syn_bndrs + ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env + + ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls + final_gbl_env = gbl_env { tcg_field_env = field_env' } + ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } + where + new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])] + new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds + new_ps _ = panic "new_ps" + + new_ps' :: LHsBindLR GhcPs GhcPs + -> [(Name, [FieldLabel])] + -> TcM [(Name, [FieldLabel])] + new_ps' bind names + | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n + , psb_args = RecCon as }))) <- bind + = do + bnd_name <- newTopSrcBinder (L bind_loc n) + let rnames = map recordPatSynSelectorId as + mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs + mkFieldOcc (L l name) = L l (FieldOcc noExtField (L l name)) + field_occs = map mkFieldOcc rnames + flds <- mapM (newRecordSelector False [bnd_name]) field_occs + return ((bnd_name, flds): names) + | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind + = do + bnd_name <- newTopSrcBinder (L bind_loc n) + return ((bnd_name, []): names) + | otherwise + = return names + +{- +********************************************************* +* * +\subsection{Support code to rename types} +* * +********************************************************* +-} + +rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn] +rnFds fds + = mapM (wrapLocM rn_fds) fds + where + rn_fds (tys1, tys2) + = do { tys1' <- rnHsTyVars tys1 + ; tys2' <- rnHsTyVars tys2 + ; return (tys1', tys2') } + +rnHsTyVars :: [Located RdrName] -> RnM [Located Name] +rnHsTyVars tvs = mapM rnHsTyVar tvs + +rnHsTyVar :: Located RdrName -> RnM (Located Name) +rnHsTyVar (L l tyvar) = do + tyvar' <- lookupOccRn tyvar + return (L l tyvar') + +{- +********************************************************* +* * + findSplice +* * +********************************************************* + +This code marches down the declarations, looking for the first +Template Haskell splice. As it does so it + a) groups the declarations into a HsGroup + b) runs any top-level quasi-quotes +-} + +findSplice :: [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) +findSplice ds = addl emptyRdrGroup ds + +addl :: HsGroup GhcPs -> [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) +-- This stuff reverses the declarations (again) but it doesn't matter +addl gp [] = return (gp, Nothing) +addl gp (L l d : ds) = add gp l d ds + + +add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) + +-- #10047: Declaration QuasiQuoters are expanded immediately, without +-- causing a group split +add gp _ (SpliceD _ (SpliceDecl _ (L _ qq@HsQuasiQuote{}) _)) ds + = do { (ds', _) <- rnTopSpliceDecls qq + ; addl gp (ds' ++ ds) + } + +add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds + = do { -- We've found a top-level splice. If it is an *implicit* one + -- (i.e. a naked top level expression) + case flag of + ExplicitSplice -> return () + ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell + ; unless th_on $ setSrcSpan loc $ + failWith badImplicitSplice } + + ; return (gp, Just (splice, ds)) } + where + badImplicitSplice = text "Parse error: module header, import declaration" + $$ text "or top-level declaration expected." + -- The compiler should suggest the above, and not using + -- TemplateHaskell since the former suggestion is more + -- relevant to the larger base of users. + -- See #12146 for discussion. + +-- Class declarations: pull out the fixity signatures to the top +add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds + | isClassDecl d + = let fsigs = [ L l f + | L l (FixSig _ f) <- tcdSigs d ] in + addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds + | otherwise + = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds + +-- Signatures: fixity sigs go a different place than all others +add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds + = addl (gp {hs_fixds = L l f : ts}) ds + +-- Standalone kind signatures: added to the TyClGroup +add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds + = addl (gp {hs_tyclds = add_kisig (L l s) ts}) ds + +add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds + = addl (gp {hs_valds = add_sig (L l d) ts}) ds + +-- Value declarations: use add_bind +add gp@(HsGroup {hs_valds = ts}) l (ValD _ d) ds + = addl (gp { hs_valds = add_bind (L l d) ts }) ds + +-- Role annotations: added to the TyClGroup +add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds + = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds + +-- NB instance declarations go into TyClGroups. We throw them into the first +-- group, just as we do for the TyClD case. The renamer will go on to group +-- and order them later. +add gp@(HsGroup {hs_tyclds = ts}) l (InstD _ d) ds + = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds + +-- The rest are routine +add gp@(HsGroup {hs_derivds = ts}) l (DerivD _ d) ds + = addl (gp { hs_derivds = L l d : ts }) ds +add gp@(HsGroup {hs_defds = ts}) l (DefD _ d) ds + = addl (gp { hs_defds = L l d : ts }) ds +add gp@(HsGroup {hs_fords = ts}) l (ForD _ d) ds + = addl (gp { hs_fords = L l d : ts }) ds +add gp@(HsGroup {hs_warnds = ts}) l (WarningD _ d) ds + = addl (gp { hs_warnds = L l d : ts }) ds +add gp@(HsGroup {hs_annds = ts}) l (AnnD _ d) ds + = addl (gp { hs_annds = L l d : ts }) ds +add gp@(HsGroup {hs_ruleds = ts}) l (RuleD _ d) ds + = addl (gp { hs_ruleds = L l d : ts }) ds +add gp l (DocD _ d) ds + = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds +add (HsGroup {}) _ (SpliceD _ (XSpliceDecl nec)) _ = noExtCon nec +add (HsGroup {}) _ (XHsDecl nec) _ = noExtCon nec +add (XHsGroup nec) _ _ _ = noExtCon nec + +add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)] + -> [TyClGroup (GhcPass p)] +add_tycld d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [d] + , group_kisigs = [] + , group_roles = [] + , group_instds = [] + } + ] +add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss) + = ds { group_tyclds = d : tyclds } : dss +add_tycld _ (XTyClGroup nec: _) = noExtCon nec + +add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)] + -> [TyClGroup (GhcPass p)] +add_instd d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [] + , group_roles = [] + , group_instds = [d] + } + ] +add_instd d (ds@(TyClGroup { group_instds = instds }):dss) + = ds { group_instds = d : instds } : dss +add_instd _ (XTyClGroup nec: _) = noExtCon nec + +add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)] + -> [TyClGroup (GhcPass p)] +add_role_annot d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [] + , group_roles = [d] + , group_instds = [] + } + ] +add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest) + = tycls { group_roles = d : roles } : rest +add_role_annot _ (XTyClGroup nec: _) = noExtCon nec + +add_kisig :: LStandaloneKindSig (GhcPass p) + -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)] +add_kisig d [] = [TyClGroup { group_ext = noExtField + , group_tyclds = [] + , group_kisigs = [d] + , group_roles = [] + , group_instds = [] + } + ] +add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest) + = tycls { group_kisigs = d : kisigs } : rest +add_kisig _ (XTyClGroup nec : _) = noExtCon nec + +add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a +add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs +add_bind _ (XValBindsLR {}) = panic "RdrHsSyn:add_bind" + +add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) +add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs) +add_sig _ (XValBindsLR {}) = panic "RdrHsSyn:add_sig" diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs new file mode 100644 index 0000000000..5211834c0e --- /dev/null +++ b/compiler/GHC/Rename/Splice.hs @@ -0,0 +1,902 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module GHC.Rename.Splice ( + rnTopSpliceDecls, + rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl, + rnBracket, + checkThLocalName + , traceSplice, SpliceInfo(..) + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Name +import NameSet +import GHC.Hs +import RdrName +import TcRnMonad + +import GHC.Rename.Env +import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn ) +import GHC.Rename.Unbound ( isUnboundName ) +import GHC.Rename.Source ( rnSrcDecls, findSplice ) +import GHC.Rename.Pat ( rnPat ) +import BasicTypes ( TopLevelFlag, isTopLevel, SourceText(..) ) +import Outputable +import Module +import SrcLoc +import GHC.Rename.Types ( rnLHsType ) + +import Control.Monad ( unless, when ) + +import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) + +import TcEnv ( checkWellStaged ) +import THNames ( liftName ) + +import DynFlags +import FastString +import ErrUtils ( dumpIfSet_dyn_printer, DumpFormat (..) ) +import TcEnv ( tcMetaTy ) +import Hooks +import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeName + , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) + +import {-# SOURCE #-} TcExpr ( tcPolyExpr ) +import {-# SOURCE #-} TcSplice + ( runMetaD + , runMetaE + , runMetaP + , runMetaT + , tcTopSpliceExpr + ) + +import TcHsSyn + +import GHCi.RemoteTypes ( ForeignRef ) +import qualified Language.Haskell.TH as TH (Q) + +import qualified GHC.LanguageExtensions as LangExt + +{- +************************************************************************ +* * + Template Haskell brackets +* * +************************************************************************ +-} + +rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars) +rnBracket e br_body + = addErrCtxt (quotationCtxtDoc br_body) $ + do { -- Check that -XTemplateHaskellQuotes is enabled and available + thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes + ; unless thQuotesEnabled $ + failWith ( vcat + [ text "Syntax error on" <+> ppr e + , text ("Perhaps you intended to use TemplateHaskell" + ++ " or TemplateHaskellQuotes") ] ) + + -- Check for nested brackets + ; cur_stage <- getStage + ; case cur_stage of + { Splice Typed -> checkTc (isTypedBracket br_body) + illegalUntypedBracket + ; Splice Untyped -> checkTc (not (isTypedBracket br_body)) + illegalTypedBracket + ; RunSplice _ -> + -- See Note [RunSplice ThLevel] in "TcRnTypes". + pprPanic "rnBracket: Renaming bracket when running a splice" + (ppr e) + ; Comp -> return () + ; Brack {} -> failWithTc illegalBracket + } + + -- Brackets are desugared to code that mentions the TH package + ; recordThUse + + ; case isTypedBracket br_body of + True -> do { traceRn "Renaming typed TH bracket" empty + ; (body', fvs_e) <- + setStage (Brack cur_stage RnPendingTyped) $ + rn_bracket cur_stage br_body + ; return (HsBracket noExtField body', fvs_e) } + + False -> do { traceRn "Renaming untyped TH bracket" empty + ; ps_var <- newMutVar [] + ; (body', fvs_e) <- + setStage (Brack cur_stage (RnPendingUntyped ps_var)) $ + rn_bracket cur_stage br_body + ; pendings <- readMutVar ps_var + ; return (HsRnBracketOut noExtField body' pendings, fvs_e) } + } + +rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars) +rn_bracket outer_stage br@(VarBr x flg rdr_name) + = do { name <- lookupOccRn rdr_name + ; this_mod <- getModule + + ; when (flg && nameIsLocalOrFrom this_mod name) $ + -- Type variables can be quoted in TH. See #5721. + do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name + ; case mb_bind_lvl of + { Nothing -> return () -- Can happen for data constructors, + -- but nothing needs to be done for them + + ; Just (top_lvl, bind_lvl) -- See Note [Quoting names] + | isTopLevel top_lvl + -> when (isExternalName name) (keepAlive name) + | otherwise + -> do { traceRn "rn_bracket VarBr" + (ppr name <+> ppr bind_lvl + <+> ppr outer_stage) + ; checkTc (thLevel outer_stage + 1 == bind_lvl) + (quotedNameStageErr br) } + } + } + ; return (VarBr x flg name, unitFV name) } + +rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e + ; return (ExpBr x e', fvs) } + +rn_bracket _ (PatBr x p) + = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs) + +rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t + ; return (TypBr x t', fvs) } + +rn_bracket _ (DecBrL x decls) + = do { group <- groupDecls decls + ; gbl_env <- getGblEnv + ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs } + -- The emptyDUs is so that we just collect uses for this + -- group alone in the call to rnSrcDecls below + ; (tcg_env, group') <- setGblEnv new_gbl_env $ + rnSrcDecls group + + -- Discard the tcg_env; it contains only extra info about fixity + ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$ + ppr (duUses (tcg_dus tcg_env))) + ; return (DecBrG x group', duUses (tcg_dus tcg_env)) } + where + groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs) + groupDecls decls + = do { (group, mb_splice) <- findSplice decls + ; case mb_splice of + { Nothing -> return group + ; Just (splice, rest) -> + do { group' <- groupDecls rest + ; let group'' = appendGroups group group' + ; return group'' { hs_splcds = noLoc splice : hs_splcds group' } + } + }} + +rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG" + +rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e + ; return (TExpBr x e', fvs) } + +rn_bracket _ (XBracket nec) = noExtCon nec + +quotationCtxtDoc :: HsBracket GhcPs -> SDoc +quotationCtxtDoc br_body + = hang (text "In the Template Haskell quotation") + 2 (ppr br_body) + +illegalBracket :: SDoc +illegalBracket = + text "Template Haskell brackets cannot be nested" <+> + text "(without intervening splices)" + +illegalTypedBracket :: SDoc +illegalTypedBracket = + text "Typed brackets may only appear in typed splices." + +illegalUntypedBracket :: SDoc +illegalUntypedBracket = + text "Untyped brackets may only appear in untyped splices." + +quotedNameStageErr :: HsBracket GhcPs -> SDoc +quotedNameStageErr br + = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br + , text "must be used at the same stage at which it is bound" ] + + +{- +********************************************************* +* * + Splices +* * +********************************************************* + +Note [Free variables of typed splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider renaming this: + f = ... + h = ...$(thing "f")... + +where the splice is a *typed* splice. The splice can expand into +literally anything, so when we do dependency analysis we must assume +that it might mention 'f'. So we simply treat all locally-defined +names as mentioned by any splice. This is terribly brutal, but I +don't see what else to do. For example, it'll mean that every +locally-defined thing will appear to be used, so no unused-binding +warnings. But if we miss the dependency, then we might typecheck 'h' +before 'f', and that will crash the type checker because 'f' isn't in +scope. + +Currently, I'm not treating a splice as also mentioning every import, +which is a bit inconsistent -- but there are a lot of them. We might +thereby get some bogus unused-import warnings, but we won't crash the +type checker. Not very satisfactory really. + +Note [Renamer errors] +~~~~~~~~~~~~~~~~~~~~~ +It's important to wrap renamer calls in checkNoErrs, because the +renamer does not fail for out of scope variables etc. Instead it +returns a bogus term/type, so that it can report more than one error. +We don't want the type checker to see these bogus unbound variables. +-} + +rnSpliceGen :: (HsSplice GhcRn -> RnM (a, FreeVars)) + -- Outside brackets, run splice + -> (HsSplice GhcRn -> (PendingRnSplice, a)) + -- Inside brackets, make it pending + -> HsSplice GhcPs + -> RnM (a, FreeVars) +rnSpliceGen run_splice pend_splice splice + = addErrCtxt (spliceCtxt splice) $ do + { stage <- getStage + ; case stage of + Brack pop_stage RnPendingTyped + -> do { checkTc is_typed_splice illegalUntypedSplice + ; (splice', fvs) <- setStage pop_stage $ + rnSplice splice + ; let (_pending_splice, result) = pend_splice splice' + ; return (result, fvs) } + + Brack pop_stage (RnPendingUntyped ps_var) + -> do { checkTc (not is_typed_splice) illegalTypedSplice + ; (splice', fvs) <- setStage pop_stage $ + rnSplice splice + ; let (pending_splice, result) = pend_splice splice' + ; ps <- readMutVar ps_var + ; writeMutVar ps_var (pending_splice : ps) + ; return (result, fvs) } + + _ -> do { (splice', fvs1) <- checkNoErrs $ + setStage (Splice splice_type) $ + rnSplice splice + -- checkNoErrs: don't attempt to run the splice if + -- renaming it failed; otherwise we get a cascade of + -- errors from e.g. unbound variables + ; (result, fvs2) <- run_splice splice' + ; return (result, fvs1 `plusFV` fvs2) } } + where + is_typed_splice = isTypedSplice splice + splice_type = if is_typed_splice + then Typed + else Untyped + +------------------ + +-- | Returns the result of running a splice and the modFinalizers collected +-- during the execution. +-- +-- See Note [Delaying modFinalizers in untyped splices]. +runRnSplice :: UntypedSpliceFlavour + -> (LHsExpr GhcTc -> TcRn res) + -> (res -> SDoc) -- How to pretty-print res + -- Usually just ppr, but not for [Decl] + -> HsSplice GhcRn -- Always untyped + -> TcRn (res, [ForeignRef (TH.Q ())]) +runRnSplice flavour run_meta ppr_res splice + = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice) + + ; let the_expr = case splice' of + HsUntypedSplice _ _ _ e -> e + HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str + HsTypedSplice {} -> pprPanic "runRnSplice" (ppr splice) + HsSpliced {} -> pprPanic "runRnSplice" (ppr splice) + HsSplicedT {} -> pprPanic "runRnSplice" (ppr splice) + XSplice nec -> noExtCon nec + + -- Typecheck the expression + ; meta_exp_ty <- tcMetaTy meta_ty_name + ; zonked_q_expr <- zonkTopLExpr =<< + tcTopSpliceExpr Untyped + (tcPolyExpr the_expr meta_exp_ty) + + -- Run the expression + ; mod_finalizers_ref <- newTcRef [] + ; result <- setStage (RunSplice mod_finalizers_ref) $ + run_meta zonked_q_expr + ; mod_finalizers <- readTcRef mod_finalizers_ref + ; traceSplice (SpliceInfo { spliceDescription = what + , spliceIsDecl = is_decl + , spliceSource = Just the_expr + , spliceGenerated = ppr_res result }) + + ; return (result, mod_finalizers) } + + where + meta_ty_name = case flavour of + UntypedExpSplice -> expQTyConName + UntypedPatSplice -> patQTyConName + UntypedTypeSplice -> typeQTyConName + UntypedDeclSplice -> decsQTyConName + what = case flavour of + UntypedExpSplice -> "expression" + UntypedPatSplice -> "pattern" + UntypedTypeSplice -> "type" + UntypedDeclSplice -> "declarations" + is_decl = case flavour of + UntypedDeclSplice -> True + _ -> False + +------------------ +makePending :: UntypedSpliceFlavour + -> HsSplice GhcRn + -> PendingRnSplice +makePending flavour (HsUntypedSplice _ _ n e) + = PendingRnSplice flavour n e +makePending flavour (HsQuasiQuote _ n quoter q_span quote) + = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote) +makePending _ splice@(HsTypedSplice {}) + = pprPanic "makePending" (ppr splice) +makePending _ splice@(HsSpliced {}) + = pprPanic "makePending" (ppr splice) +makePending _ splice@(HsSplicedT {}) + = pprPanic "makePending" (ppr splice) +makePending _ (XSplice nec) + = noExtCon nec + +------------------ +mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString + -> LHsExpr GhcRn +-- Return the expression (quoter "...quote...") +-- which is what we must run in a quasi-quote +mkQuasiQuoteExpr flavour quoter q_span quote + = L q_span $ HsApp noExtField (L q_span + $ HsApp noExtField (L q_span (HsVar noExtField (L q_span quote_selector))) + quoterExpr) + quoteExpr + where + quoterExpr = L q_span $! HsVar noExtField $! (L q_span quoter) + quoteExpr = L q_span $! HsLit noExtField $! HsString NoSourceText quote + quote_selector = case flavour of + UntypedExpSplice -> quoteExpName + UntypedPatSplice -> quotePatName + UntypedTypeSplice -> quoteTypeName + UntypedDeclSplice -> quoteDecName + +--------------------- +rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) +-- Not exported...used for all +rnSplice (HsTypedSplice x hasParen splice_name expr) + = do { loc <- getSrcSpanM + ; n' <- newLocalBndrRn (L loc splice_name) + ; (expr', fvs) <- rnLExpr expr + ; return (HsTypedSplice x hasParen n' expr', fvs) } + +rnSplice (HsUntypedSplice x hasParen splice_name expr) + = do { loc <- getSrcSpanM + ; n' <- newLocalBndrRn (L loc splice_name) + ; (expr', fvs) <- rnLExpr expr + ; return (HsUntypedSplice x hasParen n' expr', fvs) } + +rnSplice (HsQuasiQuote x splice_name quoter q_loc quote) + = do { loc <- getSrcSpanM + ; splice_name' <- newLocalBndrRn (L loc splice_name) + + -- Rename the quoter; akin to the HsVar case of rnExpr + ; quoter' <- lookupOccRn quoter + ; this_mod <- getModule + ; when (nameIsLocalOrFrom this_mod quoter') $ + checkThLocalName quoter' + + ; return (HsQuasiQuote x splice_name' quoter' q_loc quote + , unitFV quoter') } + +rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) +rnSplice splice@(HsSplicedT {}) = pprPanic "rnSplice" (ppr splice) +rnSplice (XSplice nec) = noExtCon nec + +--------------------- +rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars) +rnSpliceExpr splice + = rnSpliceGen run_expr_splice pend_expr_splice splice + where + pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn) + pend_expr_splice rn_splice + = (makePending UntypedExpSplice rn_splice, HsSpliceE noExtField rn_splice) + + run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars) + run_expr_splice rn_splice + | isTypedSplice rn_splice -- Run it later, in the type checker + = do { -- Ugh! See Note [Splices] above + traceRn "rnSpliceExpr: typed expression splice" empty + ; lcl_rdr <- getLocalRdrEnv + ; gbl_rdr <- getGlobalRdrEnv + ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr + , isLocalGRE gre] + lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) + + ; return (HsSpliceE noExtField rn_splice, lcl_names `plusFV` gbl_names) } + + | otherwise -- Run it here, see Note [Running splices in the Renamer] + = do { traceRn "rnSpliceExpr: untyped expression splice" empty + ; (rn_expr, mod_finalizers) <- + runRnSplice UntypedExpSplice runMetaE ppr rn_splice + ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr) + -- See Note [Delaying modFinalizers in untyped splices]. + ; return ( HsPar noExtField $ HsSpliceE noExtField + . HsSpliced noExtField (ThModFinalizers mod_finalizers) + . HsSplicedExpr <$> + lexpr3 + , fvs) + } + +{- Note [Running splices in the Renamer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Splices used to be run in the typechecker, which led to (#4364). Since the +renamer must decide which expressions depend on which others, and it cannot +reliably do this for arbitrary splices, we used to conservatively say that +splices depend on all other expressions in scope. Unfortunately, this led to +the problem of cyclic type declarations seen in (#4364). Instead, by +running splices in the renamer, we side-step the problem of determining +dependencies: by the time the dependency analysis happens, any splices have +already been run, and expression dependencies can be determined as usual. + +However, see (#9813), for an example where we would like to run splices +*after* performing dependency analysis (that is, after renaming). It would be +desirable to typecheck "non-splicy" expressions (those expressions that do not +contain splices directly or via dependence on an expression that does) before +"splicy" expressions, such that types/expressions within the same declaration +group would be available to `reify` calls, for example consider the following: + +> module M where +> data D = C +> f = 1 +> g = $(mapM reify ['f, 'D, ''C] ...) + +Compilation of this example fails since D/C/f are not in the type environment +and thus cannot be reified as they have not been typechecked by the time the +splice is renamed and thus run. + +These requirements are at odds: we do not want to run splices in the renamer as +we wish to first determine dependencies and typecheck certain expressions, +making them available to reify, but cannot accurately determine dependencies +without running splices in the renamer! + +Indeed, the conclusion of (#9813) was that it is not worth the complexity +to try and + a) implement and maintain the code for renaming/typechecking non-splicy + expressions before splicy expressions, + b) explain to TH users which expressions are/not available to reify at any + given point. + +-} + +{- Note [Delaying modFinalizers in untyped splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When splices run in the renamer, 'reify' does not have access to the local +type environment (#11832, [1]). + +For instance, in + +> let x = e in $(reify (mkName "x") >>= runIO . print >> [| return () |]) + +'reify' cannot find @x@, because the local type environment is not yet +populated. To address this, we allow 'reify' execution to be deferred with +'addModFinalizer'. + +> let x = e in $(do addModFinalizer (reify (mkName "x") >>= runIO . print) + [| return () |] + ) + +The finalizer is run with the local type environment when type checking is +complete. + +Since the local type environment is not available in the renamer, we annotate +the tree at the splice point [2] with @HsSpliceE (HsSpliced finalizers e)@ where +@e@ is the result of splicing and @finalizers@ are the finalizers that have been +collected during evaluation of the splice [3]. In our example, + +> HsLet +> (x = e) +> (HsSpliceE $ HsSpliced [reify (mkName "x") >>= runIO . print] +> (HsSplicedExpr $ return ()) +> ) + +When the typechecker finds the annotation, it inserts the finalizers in the +global environment and exposes the current local environment to them [4, 5, 6]. + +> addModFinalizersWithLclEnv [reify (mkName "x") >>= runIO . print] + +References: + +[1] https://gitlab.haskell.org/ghc/ghc/wikis/template-haskell/reify +[2] 'rnSpliceExpr' +[3] 'TcSplice.qAddModFinalizer' +[4] 'TcExpr.tcExpr' ('HsSpliceE' ('HsSpliced' ...)) +[5] 'TcHsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...)) +[6] 'TcPat.tc_pat' ('SplicePat' ('HsSpliced' ...)) + +-} + +---------------------- +rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars) +rnSpliceType splice + = rnSpliceGen run_type_splice pend_type_splice splice + where + pend_type_splice rn_splice + = ( makePending UntypedTypeSplice rn_splice + , HsSpliceTy noExtField rn_splice) + + run_type_splice rn_splice + = do { traceRn "rnSpliceType: untyped type splice" empty + ; (hs_ty2, mod_finalizers) <- + runRnSplice UntypedTypeSplice runMetaT ppr rn_splice + ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2 + ; checkNoErrs $ rnLHsType doc hs_ty2 } + -- checkNoErrs: see Note [Renamer errors] + -- See Note [Delaying modFinalizers in untyped splices]. + ; return ( HsParTy noExtField + $ HsSpliceTy noExtField + . HsSpliced noExtField (ThModFinalizers mod_finalizers) + . HsSplicedTy <$> + hs_ty3 + , fvs + ) } + -- Wrap the result of the splice in parens so that we don't + -- lose the outermost location set by runQuasiQuote (#7918) + +{- Note [Partial Type Splices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Partial Type Signatures are partially supported in TH type splices: only +anonymous wild cards are allowed. + + -- ToDo: SLPJ says: I don't understand all this + +Normally, named wild cards are collected before renaming a (partial) type +signature. However, TH type splices are run during renaming, i.e. after the +initial traversal, leading to out of scope errors for named wild cards. We +can't just extend the initial traversal to collect the named wild cards in TH +type splices, as we'd need to expand them, which is supposed to happen only +once, during renaming. + +Similarly, the extra-constraints wild card is handled right before renaming +too, and is therefore also not supported in a TH type splice. Another reason +to forbid extra-constraints wild cards in TH type splices is that a single +signature can contain many TH type splices, whereas it mustn't contain more +than one extra-constraints wild card. Enforcing would this be hard the way +things are currently organised. + +Anonymous wild cards pose no problem, because they start out without names and +are given names during renaming. These names are collected right after +renaming. The names generated for anonymous wild cards in TH type splices will +thus be collected as well. + +For more details about renaming wild cards, see GHC.Rename.Types.rnHsSigWcType + +Note that partial type signatures are fully supported in TH declaration +splices, e.g.: + + [d| foo :: _ => _ + foo x y = x == y |] + +This is because in this case, the partial type signature can be treated as a +whole signature, instead of as an arbitrary type. + +-} + + +---------------------- +-- | Rename a splice pattern. See Note [rnSplicePat] +rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn) + , FreeVars) +rnSplicePat splice + = rnSpliceGen run_pat_splice pend_pat_splice splice + where + pend_pat_splice :: HsSplice GhcRn -> + (PendingRnSplice, Either b (Pat GhcRn)) + pend_pat_splice rn_splice + = (makePending UntypedPatSplice rn_splice + , Right (SplicePat noExtField rn_splice)) + + run_pat_splice :: HsSplice GhcRn -> + RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars) + run_pat_splice rn_splice + = do { traceRn "rnSplicePat: untyped pattern splice" empty + ; (pat, mod_finalizers) <- + runRnSplice UntypedPatSplice runMetaP ppr rn_splice + -- See Note [Delaying modFinalizers in untyped splices]. + ; return ( Left $ ParPat noExtField $ ((SplicePat noExtField) + . HsSpliced noExtField (ThModFinalizers mod_finalizers) + . HsSplicedPat) `mapLoc` + pat + , emptyFVs + ) } + -- Wrap the result of the quasi-quoter in parens so that we don't + -- lose the outermost location set by runQuasiQuote (#7918) + +---------------------- +rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) +rnSpliceDecl (SpliceDecl _ (L loc splice) flg) + = rnSpliceGen run_decl_splice pend_decl_splice splice + where + pend_decl_splice rn_splice + = ( makePending UntypedDeclSplice rn_splice + , SpliceDecl noExtField (L loc rn_splice) flg) + + run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) +rnSpliceDecl (XSpliceDecl nec) = noExtCon nec + +rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) +-- Declaration splice at the very top level of the module +rnTopSpliceDecls splice + = do { (rn_splice, fvs) <- checkNoErrs $ + setStage (Splice Untyped) $ + rnSplice splice + -- As always, be sure to checkNoErrs above lest we end up with + -- holes making it to typechecking, hence #12584. + -- + -- Note that we cannot call checkNoErrs for the whole duration + -- of rnTopSpliceDecls. The reason is that checkNoErrs changes + -- the local environment to temporarily contain a new + -- reference to store errors, and add_mod_finalizers would + -- cause this reference to be stored after checkNoErrs finishes. + -- This is checked by test TH_finalizer. + ; traceRn "rnTopSpliceDecls: untyped declaration splice" empty + ; (decls, mod_finalizers) <- checkNoErrs $ + runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice + ; add_mod_finalizers_now mod_finalizers + ; return (decls,fvs) } + where + ppr_decls :: [LHsDecl GhcPs] -> SDoc + ppr_decls ds = vcat (map ppr ds) + + -- Adds finalizers to the global environment instead of delaying them + -- to the type checker. + -- + -- Declaration splices do not have an interesting local environment so + -- there is no point in delaying them. + -- + -- See Note [Delaying modFinalizers in untyped splices]. + add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn () + add_mod_finalizers_now [] = return () + add_mod_finalizers_now mod_finalizers = do + th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv + env <- getLclEnv + updTcRef th_modfinalizers_var $ \fins -> + (env, ThModFinalizers mod_finalizers) : fins + + +{- +Note [rnSplicePat] +~~~~~~~~~~~~~~~~~~ +Renaming a pattern splice is a bit tricky, because we need the variables +bound in the pattern to be in scope in the RHS of the pattern. This scope +management is effectively done by using continuation-passing style in +GHC.Rename.Pat, through the CpsRn monad. We don't wish to be in that monad here +(it would create import cycles and generally conflict with renaming other +splices), so we really want to return a (Pat RdrName) -- the result of +running the splice -- which can then be further renamed in GHC.Rename.Pat, in +the CpsRn monad. + +The problem is that if we're renaming a splice within a bracket, we +*don't* want to run the splice now. We really do just want to rename +it to an HsSplice Name. Of course, then we can't know what variables +are bound within the splice. So we accept any unbound variables and +rename them again when the bracket is spliced in. If a variable is brought +into scope by a pattern splice all is fine. If it is not then an error is +reported. + +In any case, when we're done in rnSplicePat, we'll either have a +Pat RdrName (the result of running a top-level splice) or a Pat Name +(the renamed nested splice). Thus, the awkward return type of +rnSplicePat. +-} + +spliceCtxt :: HsSplice GhcPs -> SDoc +spliceCtxt splice + = hang (text "In the" <+> what) 2 (ppr splice) + where + what = case splice of + HsUntypedSplice {} -> text "untyped splice:" + HsTypedSplice {} -> text "typed splice:" + HsQuasiQuote {} -> text "quasi-quotation:" + HsSpliced {} -> text "spliced expression:" + HsSplicedT {} -> text "spliced expression:" + XSplice {} -> text "spliced expression:" + +-- | The splice data to be logged +data SpliceInfo + = SpliceInfo + { spliceDescription :: String + , spliceSource :: Maybe (LHsExpr GhcRn) -- Nothing <=> top-level decls + -- added by addTopDecls + , spliceIsDecl :: Bool -- True <=> put the generate code in a file + -- when -dth-dec-file is on + , spliceGenerated :: SDoc + } + -- Note that 'spliceSource' is *renamed* but not *typechecked* + -- Reason (a) less typechecking crap + -- (b) data constructors after type checking have been + -- changed to their *wrappers*, and that makes them + -- print always fully qualified + +-- | outputs splice information for 2 flags which have different output formats: +-- `-ddump-splices` and `-dth-dec-file` +traceSplice :: SpliceInfo -> TcM () +traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src + , spliceGenerated = gen, spliceIsDecl = is_decl }) + = do { loc <- case mb_src of + Nothing -> getSrcSpanM + Just (L loc _) -> return loc + ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) + + ; when is_decl $ -- Raw material for -dth-dec-file + do { dflags <- getDynFlags + ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file + "" FormatHaskell (spliceCodeDoc loc) } } + where + -- `-ddump-splices` + spliceDebugDoc :: SrcSpan -> SDoc + spliceDebugDoc loc + = let code = case mb_src of + Nothing -> ending + Just e -> nest 2 (ppr (stripParensHsExpr e)) : ending + ending = [ text "======>", nest 2 gen ] + in hang (ppr loc <> colon <+> text "Splicing" <+> text sd) + 2 (sep code) + + -- `-dth-dec-file` + spliceCodeDoc :: SrcSpan -> SDoc + spliceCodeDoc loc + = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd + , gen ] + +illegalTypedSplice :: SDoc +illegalTypedSplice = text "Typed splices may not appear in untyped brackets" + +illegalUntypedSplice :: SDoc +illegalUntypedSplice = text "Untyped splices may not appear in typed brackets" + +checkThLocalName :: Name -> RnM () +checkThLocalName name + | isUnboundName name -- Do not report two errors for + = return () -- $(not_in_scope args) + + | otherwise + = do { traceRn "checkThLocalName" (ppr name) + ; mb_local_use <- getStageAndBindLevel name + ; case mb_local_use of { + Nothing -> return () ; -- Not a locally-bound thing + Just (top_lvl, bind_lvl, use_stage) -> + do { let use_lvl = thLevel use_stage + ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl + ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl + <+> ppr use_stage + <+> ppr use_lvl) + ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } } + +-------------------------------------- +checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel + -> Name -> TcM () +-- We are inside brackets, and (use_lvl > bind_lvl) +-- Now we must check whether there's a cross-stage lift to do +-- Examples \x -> [| x |] +-- [| map |] +-- +-- This code is similar to checkCrossStageLifting in TcExpr, but +-- this is only run on *untyped* brackets. + +checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name + | Brack _ (RnPendingUntyped ps_var) <- use_stage -- Only for untyped brackets + , use_lvl > bind_lvl -- Cross-stage condition + = check_cross_stage_lifting top_lvl name ps_var + | otherwise + = return () + +check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM () +check_cross_stage_lifting top_lvl name ps_var + | isTopLevel top_lvl + -- Top-level identifiers in this module, + -- (which have External Names) + -- are just like the imported case: + -- no need for the 'lifting' treatment + -- E.g. this is fine: + -- f x = x + -- g y = [| f 3 |] + = when (isExternalName name) (keepAlive name) + -- See Note [Keeping things alive for Template Haskell] + + | otherwise + = -- Nested identifiers, such as 'x' in + -- E.g. \x -> [| h x |] + -- We must behave as if the reference to x was + -- h $(lift x) + -- We use 'x' itself as the SplicePointName, used by + -- the desugarer to stitch it all back together. + -- If 'x' occurs many times we may get many identical + -- bindings of the same SplicePointName, but that doesn't + -- matter, although it's a mite untidy. + do { traceRn "checkCrossStageLifting" (ppr name) + + -- Construct the (lift x) expression + ; let lift_expr = nlHsApp (nlHsVar liftName) (nlHsVar name) + pend_splice = PendingRnSplice UntypedExpSplice name lift_expr + + -- Update the pending splices + ; ps <- readMutVar ps_var + ; writeMutVar ps_var (pend_splice : ps) } + +{- +Note [Keeping things alive for Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = x+1 + g y = [| f 3 |] + +Here 'f' is referred to from inside the bracket, which turns into data +and mentions only f's *name*, not 'f' itself. So we need some other +way to keep 'f' alive, lest it get dropped as dead code. That's what +keepAlive does. It puts it in the keep-alive set, which subsequently +ensures that 'f' stays as a top level binding. + +This must be done by the renamer, not the type checker (as of old), +because the type checker doesn't typecheck the body of untyped +brackets (#8540). + +A thing can have a bind_lvl of outerLevel, but have an internal name: + foo = [d| op = 3 + bop = op + 1 |] +Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is +bound inside a bracket. That is because we don't even even record +binding levels for top-level things; the binding levels are in the +LocalRdrEnv. + +So the occurrence of 'op' in the rhs of 'bop' looks a bit like a +cross-stage thing, but it isn't really. And in fact we never need +to do anything here for top-level bound things, so all is fine, if +a bit hacky. + +For these chaps (which have Internal Names) we don't want to put +them in the keep-alive set. + +Note [Quoting names] +~~~~~~~~~~~~~~~~~~~~ +A quoted name 'n is a bit like a quoted expression [| n |], except that we +have no cross-stage lifting (c.f. TcExpr.thBrackId). So, after incrementing +the use-level to account for the brackets, the cases are: + + bind > use Error + bind = use+1 OK + bind < use + Imported things OK + Top-level things OK + Non-top-level Error + +where 'use' is the binding level of the 'n quote. (So inside the implied +bracket the level would be use+1.) + +Examples: + + f 'map -- OK; also for top-level defns of this module + + \x. f 'x -- Not ok (bind = 1, use = 1) + -- (whereas \x. f [| x |] might have been ok, by + -- cross-stage lifting + + \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1) + + [| \x. $(f 'x) |] -- OK (bind = 2, use = 1) +-} diff --git a/compiler/GHC/Rename/Splice.hs-boot b/compiler/GHC/Rename/Splice.hs-boot new file mode 100644 index 0000000000..b61a866331 --- /dev/null +++ b/compiler/GHC/Rename/Splice.hs-boot @@ -0,0 +1,14 @@ +module GHC.Rename.Splice where + +import GhcPrelude +import GHC.Hs +import TcRnMonad +import NameSet + + +rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars) +rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn) + , FreeVars ) +rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) + +rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) diff --git a/compiler/GHC/Rename/Types.hs b/compiler/GHC/Rename/Types.hs new file mode 100644 index 0000000000..b5c950618c --- /dev/null +++ b/compiler/GHC/Rename/Types.hs @@ -0,0 +1,1783 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +-} + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Rename.Types ( + -- Type related stuff + rnHsType, rnLHsType, rnLHsTypes, rnContext, + rnHsKind, rnLHsKind, rnLHsTypeArgs, + rnHsSigType, rnHsWcType, + HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped, + newTyVarNameRn, + rnConDeclFields, + rnLTyVar, + + -- Precence related stuff + mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, + checkPrecMatch, checkSectionPrec, + + -- Binding related stuff + bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs, + bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames, + extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars, + extractHsTysRdrTyVarsDups, + extractRdrKindSigVars, extractDataDefnKindVars, + extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup, + nubL, elemRdr + ) where + +import GhcPrelude + +import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType ) + +import DynFlags +import GHC.Hs +import GHC.Rename.Doc ( rnLHsDoc, rnMbLHsDoc ) +import GHC.Rename.Env +import GHC.Rename.Utils ( HsDocContext(..), withHsDocContext, mapFvRn + , pprHsDocContext, bindLocalNamesFV, typeAppErr + , newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames ) +import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn + , lookupTyFixityRn ) +import TcRnMonad +import RdrName +import PrelNames +import TysPrim ( funTyConName ) +import Name +import SrcLoc +import NameSet +import FieldLabel + +import Util +import ListSetOps ( deleteBys ) +import BasicTypes ( compareFixity, funTyFixity, negateFixity + , Fixity(..), FixityDirection(..), LexicalFixity(..) + , TypeOrKind(..) ) +import Outputable +import FastString +import Maybes +import qualified GHC.LanguageExtensions as LangExt + +import Data.List ( nubBy, partition, (\\) ) +import Control.Monad ( unless, when ) + +#include "HsVersions.h" + +{- +These type renamers are in a separate module, rather than in (say) GHC.Rename.Source, +to break several loop. + +********************************************************* +* * + HsSigWcType (i.e with wildcards) +* * +********************************************************* +-} + +data HsSigWcTypeScoping = AlwaysBind + -- ^ Always bind any free tyvars of the given type, + -- regardless of whether we have a forall at the top + | BindUnlessForall + -- ^ Unless there's forall at the top, do the same + -- thing as 'AlwaysBind' + | NeverBind + -- ^ Never bind any free tyvars + +rnHsSigWcType :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs + -> RnM (LHsSigWcType GhcRn, FreeVars) +rnHsSigWcType scoping doc sig_ty + = rn_hs_sig_wc_type scoping doc sig_ty $ \sig_ty' -> + return (sig_ty', emptyFVs) + +rnHsSigWcTypeScoped :: HsSigWcTypeScoping + -- AlwaysBind: for pattern type sigs and rules we /do/ want + -- to bring those type variables into scope, even + -- if there's a forall at the top which usually + -- stops that happening + -- e.g \ (x :: forall a. a-> b) -> e + -- Here we do bring 'b' into scope + -> HsDocContext -> LHsSigWcType GhcPs + -> (LHsSigWcType GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +-- Used for +-- - Signatures on binders in a RULE +-- - Pattern type signatures +-- Wildcards are allowed +-- type signatures on binders only allowed with ScopedTypeVariables +rnHsSigWcTypeScoped scoping ctx sig_ty thing_inside + = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables + ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty) + ; rn_hs_sig_wc_type scoping ctx sig_ty thing_inside + } + +rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs + -> (LHsSigWcType GhcRn -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +-- rn_hs_sig_wc_type is used for source-language type signatures +rn_hs_sig_wc_type scoping ctxt + (HsWC { hswc_body = HsIB { hsib_body = hs_ty }}) + thing_inside + = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty + ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars + ; let nwc_rdrs = nubL nwc_rdrs' + bind_free_tvs = case scoping of + AlwaysBind -> True + BindUnlessForall -> not (isLHsForAllTy hs_ty) + NeverBind -> False + ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars -> + do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty + ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' } + ib_ty' = HsIB { hsib_ext = vars + , hsib_body = hs_ty' } + ; (res, fvs2) <- thing_inside sig_ty' + ; return (res, fvs1 `plusFV` fvs2) } } +rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs nec)) _ + = noExtCon nec +rn_hs_sig_wc_type _ _ (XHsWildCardBndrs nec) _ + = noExtCon nec + +rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars) +rnHsWcType ctxt (HsWC { hswc_body = hs_ty }) + = do { free_vars <- extractFilteredRdrTyVars hs_ty + ; (nwc_rdrs, _) <- partition_nwcs free_vars + ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty + ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' } + ; return (sig_ty', fvs) } +rnHsWcType _ (XHsWildCardBndrs nec) = noExtCon nec + +rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs + -> RnM ([Name], LHsType GhcRn, FreeVars) +rnWcBody ctxt nwc_rdrs hs_ty + = do { nwcs <- mapM newLocalBndrRn nwc_rdrs + ; let env = RTKE { rtke_level = TypeLevel + , rtke_what = RnTypeBody + , rtke_nwcs = mkNameSet nwcs + , rtke_ctxt = ctxt } + ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $ + rn_lty env hs_ty + ; return (nwcs, hs_ty', fvs) } + where + rn_lty env (L loc hs_ty) + = setSrcSpan loc $ + do { (hs_ty', fvs) <- rn_ty env hs_ty + ; return (L loc hs_ty', fvs) } + + rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) + -- A lot of faff just to allow the extra-constraints wildcard to appear + rn_ty env hs_ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs + , hst_body = hs_body }) + = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' -> + do { (hs_body', fvs) <- rn_lty env hs_body + ; return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField + , hst_bndrs = tvs', hst_body = hs_body' } + , fvs) } + + rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt + , hst_body = hs_ty }) + | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt + , L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last + = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 + ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1 + ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)] + ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty + ; return (HsQualTy { hst_xqual = noExtField + , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' } + , fvs1 `plusFV` fvs2) } + + | otherwise + = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt + ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty + ; return (HsQualTy { hst_xqual = noExtField + , hst_ctxt = L cx hs_ctxt' + , hst_body = hs_ty' } + , fvs1 `plusFV` fvs2) } + + rn_ty env hs_ty = rnHsTyKi env hs_ty + + rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint }) + + +checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM () +-- Rename the extra-constraint spot in a type signature +-- (blah, _) => type +-- Check that extra-constraints are allowed at all, and +-- if so that it's an anonymous wildcard +checkExtraConstraintWildCard env hs_ctxt + = checkWildCard env mb_bad + where + mb_bad | not (extraConstraintWildCardsAllowed env) + = Just base_msg + -- Currently, we do not allow wildcards in their full glory in + -- standalone deriving declarations. We only allow a single + -- extra-constraints wildcard à la: + -- + -- deriving instance _ => Eq (Foo a) + -- + -- i.e., we don't support things like + -- + -- deriving instance (Eq a, _) => Eq (Foo a) + | DerivDeclCtx {} <- rtke_ctxt env + , not (null hs_ctxt) + = Just deriv_decl_msg + | otherwise + = Nothing + + base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard + <+> text "not allowed" + + deriv_decl_msg + = hang base_msg + 2 (vcat [ text "except as the sole constraint" + , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ]) + +extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool +extraConstraintWildCardsAllowed env + = case rtke_ctxt env of + TypeSigCtx {} -> True + ExprWithTySigCtx {} -> True + DerivDeclCtx {} -> True + StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls + _ -> False + +-- | Finds free type and kind variables in a type, +-- without duplicates, and +-- without variables that are already in scope in LocalRdrEnv +-- NB: this includes named wildcards, which look like perfectly +-- ordinary type variables at this point +extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups +extractFilteredRdrTyVars hs_ty = filterInScopeM (extractHsTyRdrTyVars hs_ty) + +-- | Finds free type and kind variables in a type, +-- with duplicates, but +-- without variables that are already in scope in LocalRdrEnv +-- NB: this includes named wildcards, which look like perfectly +-- ordinary type variables at this point +extractFilteredRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups +extractFilteredRdrTyVarsDups hs_ty = filterInScopeM (extractHsTyRdrTyVarsDups hs_ty) + +-- | When the NamedWildCards extension is enabled, partition_nwcs +-- removes type variables that start with an underscore from the +-- FreeKiTyVars in the argument and returns them in a separate list. +-- When the extension is disabled, the function returns the argument +-- and empty list. See Note [Renaming named wild cards] +partition_nwcs :: FreeKiTyVars -> RnM ([Located RdrName], FreeKiTyVars) +partition_nwcs free_vars + = do { wildcards_enabled <- xoptM LangExt.NamedWildCards + ; return $ + if wildcards_enabled + then partition is_wildcard free_vars + else ([], free_vars) } + where + is_wildcard :: Located RdrName -> Bool + is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr)) + +{- Note [Renaming named wild cards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Identifiers starting with an underscore are always parsed as type variables. +It is only here in the renamer that we give the special treatment. +See Note [The wildcard story for types] in GHC.Hs.Types. + +It's easy! When we collect the implicitly bound type variables, ready +to bring them into scope, and NamedWildCards is on, we partition the +variables into the ones that start with an underscore (the named +wildcards) and the rest. Then we just add them to the hswc_wcs field +of the HsWildCardBndrs structure, and we are done. + + +********************************************************* +* * + HsSigtype (i.e. no wildcards) +* * +****************************************************** -} + +rnHsSigType :: HsDocContext + -> TypeOrKind + -> LHsSigType GhcPs + -> RnM (LHsSigType GhcRn, FreeVars) +-- Used for source-language type signatures +-- that cannot have wildcards +rnHsSigType ctx level (HsIB { hsib_body = hs_ty }) + = do { traceRn "rnHsSigType" (ppr hs_ty) + ; vars <- extractFilteredRdrTyVarsDups hs_ty + ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars -> + do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty + + ; return ( HsIB { hsib_ext = vars + , hsib_body = body' } + , fvs ) } } +rnHsSigType _ _ (XHsImplicitBndrs nec) = noExtCon nec + +rnImplicitBndrs :: Bool -- True <=> bring into scope any free type variables + -- E.g. f :: forall a. a->b + -- we do not want to bring 'b' into scope, hence False + -- But f :: a -> b + -- we want to bring both 'a' and 'b' into scope + -> FreeKiTyVarsWithDups + -- Free vars of hs_ty (excluding wildcards) + -- May have duplicates, which is + -- checked here + -> ([Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +rnImplicitBndrs bind_free_tvs + fvs_with_dups + thing_inside + = do { let fvs = nubL fvs_with_dups + real_fvs | bind_free_tvs = fvs + | otherwise = [] + + ; traceRn "rnImplicitBndrs" $ + vcat [ ppr fvs_with_dups, ppr fvs, ppr real_fvs ] + + ; loc <- getSrcSpanM + ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_fvs + + ; bindLocalNamesFV vars $ + thing_inside vars } + +{- ****************************************************** +* * + LHsType and HsType +* * +****************************************************** -} + +{- +rnHsType is here because we call it from loadInstDecl, and I didn't +want a gratuitous knot. + +Note [Context quantification] +----------------------------- +Variables in type signatures are implicitly quantified +when (1) they are in a type signature not beginning +with "forall" or (2) in any qualified type T => R. +We are phasing out (2) since it leads to inconsistencies +(#4426): + +data A = A (a -> a) is an error +data A = A (Eq a => a -> a) binds "a" +data A = A (Eq a => a -> b) binds "a" and "b" +data A = A (() => a -> b) binds "a" and "b" +f :: forall a. a -> b is an error +f :: forall a. () => a -> b is an error +f :: forall a. a -> (() => b) binds "a" and "b" + +This situation is now considered to be an error. See rnHsTyKi for case +HsForAllTy Qualified. + +Note [QualTy in kinds] +~~~~~~~~~~~~~~~~~~~~~~ +I was wondering whether QualTy could occur only at TypeLevel. But no, +we can have a qualified type in a kind too. Here is an example: + + type family F a where + F Bool = Nat + F Nat = Type + + type family G a where + G Type = Type -> Type + G () = Nat + + data X :: forall k1 k2. (F k1 ~ G k2) => k1 -> k2 -> Type where + MkX :: X 'True '() + +See that k1 becomes Bool and k2 becomes (), so the equality is +satisfied. If I write MkX :: X 'True 'False, compilation fails with a +suitable message: + + MkX :: X 'True '() + • Couldn't match kind ‘G Bool’ with ‘Nat’ + Expected kind: G Bool + Actual kind: F Bool + +However: in a kind, the constraints in the QualTy must all be +equalities; or at least, any kinds with a class constraint are +uninhabited. +-} + +data RnTyKiEnv + = RTKE { rtke_ctxt :: HsDocContext + , rtke_level :: TypeOrKind -- Am I renaming a type or a kind? + , rtke_what :: RnTyKiWhat -- And within that what am I renaming? + , rtke_nwcs :: NameSet -- These are the in-scope named wildcards + } + +data RnTyKiWhat = RnTypeBody + | RnTopConstraint -- Top-level context of HsSigWcTypes + | RnConstraint -- All other constraints + +instance Outputable RnTyKiEnv where + ppr (RTKE { rtke_level = lev, rtke_what = what + , rtke_nwcs = wcs, rtke_ctxt = ctxt }) + = text "RTKE" + <+> braces (sep [ ppr lev, ppr what, ppr wcs + , pprHsDocContext ctxt ]) + +instance Outputable RnTyKiWhat where + ppr RnTypeBody = text "RnTypeBody" + ppr RnTopConstraint = text "RnTopConstraint" + ppr RnConstraint = text "RnConstraint" + +mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv +mkTyKiEnv cxt level what + = RTKE { rtke_level = level, rtke_nwcs = emptyNameSet + , rtke_what = what, rtke_ctxt = cxt } + +isRnKindLevel :: RnTyKiEnv -> Bool +isRnKindLevel (RTKE { rtke_level = KindLevel }) = True +isRnKindLevel _ = False + +-------------- +rnLHsType :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) +rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty + +rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars) +rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys + +rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) +rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty + +rnLHsKind :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars) +rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind + +rnHsKind :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars) +rnHsKind ctxt kind = rnHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind + +-- renaming a type only, not a kind +rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs + -> RnM (LHsTypeArg GhcRn, FreeVars) +rnLHsTypeArg ctxt (HsValArg ty) + = do { (tys_rn, fvs) <- rnLHsType ctxt ty + ; return (HsValArg tys_rn, fvs) } +rnLHsTypeArg ctxt (HsTypeArg l ki) + = do { (kis_rn, fvs) <- rnLHsKind ctxt ki + ; return (HsTypeArg l kis_rn, fvs) } +rnLHsTypeArg _ (HsArgPar sp) + = return (HsArgPar sp, emptyFVs) + +rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs] + -> RnM ([LHsTypeArg GhcRn], FreeVars) +rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args + +-------------- +rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs + -> RnM (LHsContext GhcRn, FreeVars) +rnTyKiContext env (L loc cxt) + = do { traceRn "rncontext" (ppr cxt) + ; let env' = env { rtke_what = RnConstraint } + ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt + ; return (L loc cxt', fvs) } + +rnContext :: HsDocContext -> LHsContext GhcPs + -> RnM (LHsContext GhcRn, FreeVars) +rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta + +-------------- +rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) +rnLHsTyKi env (L loc ty) + = setSrcSpan loc $ + do { (ty', fvs) <- rnHsTyKi env ty + ; return (L loc ty', fvs) } + +rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) + +rnHsTyKi env ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars + , hst_body = tau }) + = do { checkPolyKinds env ty + ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty) + Nothing tyvars $ \ tyvars' -> + do { (tau', fvs) <- rnLHsTyKi env tau + ; return ( HsForAllTy { hst_fvf = fvf, hst_xforall = noExtField + , hst_bndrs = tyvars' , hst_body = tau' } + , fvs) } } + +rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) + = do { checkPolyKinds env ty -- See Note [QualTy in kinds] + ; (ctxt', fvs1) <- rnTyKiContext env lctxt + ; (tau', fvs2) <- rnLHsTyKi env tau + ; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt' + , hst_body = tau' } + , fvs1 `plusFV` fvs2) } + +rnHsTyKi env (HsTyVar _ ip (L loc rdr_name)) + = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $ + unlessXOptM LangExt.PolyKinds $ addErr $ + withHsDocContext (rtke_ctxt env) $ + vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name) + , text "Perhaps you intended to use PolyKinds" ] + -- Any type variable at the kind level is illegal without the use + -- of PolyKinds (see #14710) + ; name <- rnTyVar env rdr_name + ; return (HsTyVar noExtField ip (L loc name), unitFV name) } + +rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2) + = setSrcSpan (getLoc l_op) $ + do { (l_op', fvs1) <- rnHsTyOp env ty l_op + ; fix <- lookupTyFixityRn l_op' + ; (ty1', fvs2) <- rnLHsTyKi env ty1 + ; (ty2', fvs3) <- rnLHsTyKi env ty2 + ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExtField t1 l_op' t2) + (unLoc l_op') fix ty1' ty2' + ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } + +rnHsTyKi env (HsParTy _ ty) + = do { (ty', fvs) <- rnLHsTyKi env ty + ; return (HsParTy noExtField ty', fvs) } + +rnHsTyKi env (HsBangTy _ b ty) + = do { (ty', fvs) <- rnLHsTyKi env ty + ; return (HsBangTy noExtField b ty', fvs) } + +rnHsTyKi env ty@(HsRecTy _ flds) + = do { let ctxt = rtke_ctxt env + ; fls <- get_fields ctxt + ; (flds', fvs) <- rnConDeclFields ctxt fls flds + ; return (HsRecTy noExtField flds', fvs) } + where + get_fields (ConDeclCtx names) + = concatMapM (lookupConstructorFields . unLoc) names + get_fields _ + = do { addErr (hang (text "Record syntax is illegal here:") + 2 (ppr ty)) + ; return [] } + +rnHsTyKi env (HsFunTy _ ty1 ty2) + = do { (ty1', fvs1) <- rnLHsTyKi env ty1 + -- Might find a for-all as the arg of a function type + ; (ty2', fvs2) <- rnLHsTyKi env ty2 + -- Or as the result. This happens when reading Prelude.hi + -- when we find return :: forall m. Monad m -> forall a. a -> m a + + -- Check for fixity rearrangements + ; res_ty <- mkHsOpTyRn (HsFunTy noExtField) funTyConName funTyFixity ty1' ty2' + ; return (res_ty, fvs1 `plusFV` fvs2) } + +rnHsTyKi env listTy@(HsListTy _ ty) + = do { data_kinds <- xoptM LangExt.DataKinds + ; when (not data_kinds && isRnKindLevel env) + (addErr (dataKindsErr env listTy)) + ; (ty', fvs) <- rnLHsTyKi env ty + ; return (HsListTy noExtField ty', fvs) } + +rnHsTyKi env t@(HsKindSig _ ty k) + = do { checkPolyKinds env t + ; kind_sigs_ok <- xoptM LangExt.KindSignatures + ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty) + ; (ty', lhs_fvs) <- rnLHsTyKi env ty + ; (k', sig_fvs) <- rnLHsTyKi (env { rtke_level = KindLevel }) k + ; return (HsKindSig noExtField ty' k', lhs_fvs `plusFV` sig_fvs) } + +-- Unboxed tuples are allowed to have poly-typed arguments. These +-- sometimes crop up as a result of CPR worker-wrappering dictionaries. +rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys) + = do { data_kinds <- xoptM LangExt.DataKinds + ; when (not data_kinds && isRnKindLevel env) + (addErr (dataKindsErr env tupleTy)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys + ; return (HsTupleTy noExtField tup_con tys', fvs) } + +rnHsTyKi env sumTy@(HsSumTy _ tys) + = do { data_kinds <- xoptM LangExt.DataKinds + ; when (not data_kinds && isRnKindLevel env) + (addErr (dataKindsErr env sumTy)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys + ; return (HsSumTy noExtField tys', fvs) } + +-- Ensure that a type-level integer is nonnegative (#8306, #8412) +rnHsTyKi env tyLit@(HsTyLit _ t) + = do { data_kinds <- xoptM LangExt.DataKinds + ; unless data_kinds (addErr (dataKindsErr env tyLit)) + ; when (negLit t) (addErr negLitErr) + ; checkPolyKinds env tyLit + ; return (HsTyLit noExtField t, emptyFVs) } + where + negLit (HsStrTy _ _) = False + negLit (HsNumTy _ i) = i < 0 + negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit + +rnHsTyKi env (HsAppTy _ ty1 ty2) + = do { (ty1', fvs1) <- rnLHsTyKi env ty1 + ; (ty2', fvs2) <- rnLHsTyKi env ty2 + ; return (HsAppTy noExtField ty1' ty2', fvs1 `plusFV` fvs2) } + +rnHsTyKi env (HsAppKindTy l ty k) + = do { kind_app <- xoptM LangExt.TypeApplications + ; unless kind_app (addErr (typeAppErr "kind" k)) + ; (ty', fvs1) <- rnLHsTyKi env ty + ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k + ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) } + +rnHsTyKi env t@(HsIParamTy _ n ty) + = do { notInKinds env t + ; (ty', fvs) <- rnLHsTyKi env ty + ; return (HsIParamTy noExtField n ty', fvs) } + +rnHsTyKi _ (HsStarTy _ isUni) + = return (HsStarTy noExtField isUni, emptyFVs) + +rnHsTyKi _ (HsSpliceTy _ sp) + = rnSpliceType sp + +rnHsTyKi env (HsDocTy _ ty haddock_doc) + = do { (ty', fvs) <- rnLHsTyKi env ty + ; haddock_doc' <- rnLHsDoc haddock_doc + ; return (HsDocTy noExtField ty' haddock_doc', fvs) } + +rnHsTyKi _ (XHsType (NHsCoreTy ty)) + = return (XHsType (NHsCoreTy ty), emptyFVs) + -- The emptyFVs probably isn't quite right + -- but I don't think it matters + +rnHsTyKi env ty@(HsExplicitListTy _ ip tys) + = do { checkPolyKinds env ty + ; data_kinds <- xoptM LangExt.DataKinds + ; unless data_kinds (addErr (dataKindsErr env ty)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys + ; return (HsExplicitListTy noExtField ip tys', fvs) } + +rnHsTyKi env ty@(HsExplicitTupleTy _ tys) + = do { checkPolyKinds env ty + ; data_kinds <- xoptM LangExt.DataKinds + ; unless data_kinds (addErr (dataKindsErr env ty)) + ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys + ; return (HsExplicitTupleTy noExtField tys', fvs) } + +rnHsTyKi env (HsWildCardTy _) + = do { checkAnonWildCard env + ; return (HsWildCardTy noExtField, emptyFVs) } + +-------------- +rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name +rnTyVar env rdr_name + = do { name <- lookupTypeOccRn rdr_name + ; checkNamedWildCard env name + ; return name } + +rnLTyVar :: Located RdrName -> RnM (Located Name) +-- Called externally; does not deal with wildards +rnLTyVar (L loc rdr_name) + = do { tyvar <- lookupTypeOccRn rdr_name + ; return (L loc tyvar) } + +-------------- +rnHsTyOp :: Outputable a + => RnTyKiEnv -> a -> Located RdrName + -> RnM (Located Name, FreeVars) +rnHsTyOp env overall_ty (L loc op) + = do { ops_ok <- xoptM LangExt.TypeOperators + ; op' <- rnTyVar env op + ; unless (ops_ok || op' `hasKey` eqTyConKey) $ + addErr (opTyErr op overall_ty) + ; let l_op' = L loc op' + ; return (l_op', unitFV op') } + +-------------- +notAllowed :: SDoc -> SDoc +notAllowed doc + = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed") + +checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM () +checkWildCard env (Just doc) + = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))] +checkWildCard _ Nothing + = return () + +checkAnonWildCard :: RnTyKiEnv -> RnM () +-- Report an error if an anonymous wildcard is illegal here +checkAnonWildCard env + = checkWildCard env mb_bad + where + mb_bad :: Maybe SDoc + mb_bad | not (wildCardsAllowed env) + = Just (notAllowed pprAnonWildCard) + | otherwise + = case rtke_what env of + RnTypeBody -> Nothing + RnTopConstraint -> Just constraint_msg + RnConstraint -> Just constraint_msg + + constraint_msg = hang + (notAllowed pprAnonWildCard <+> text "in a constraint") + 2 hint_msg + hint_msg = vcat [ text "except as the last top-level constraint of a type signature" + , nest 2 (text "e.g f :: (Eq a, _) => blah") ] + +checkNamedWildCard :: RnTyKiEnv -> Name -> RnM () +-- Report an error if a named wildcard is illegal here +checkNamedWildCard env name + = checkWildCard env mb_bad + where + mb_bad | not (name `elemNameSet` rtke_nwcs env) + = Nothing -- Not a wildcard + | not (wildCardsAllowed env) + = Just (notAllowed (ppr name)) + | otherwise + = case rtke_what env of + RnTypeBody -> Nothing -- Allowed + RnTopConstraint -> Nothing -- Allowed; e.g. + -- f :: (Eq _a) => _a -> Int + -- g :: (_a, _b) => T _a _b -> Int + -- The named tyvars get filled in from elsewhere + RnConstraint -> Just constraint_msg + constraint_msg = notAllowed (ppr name) <+> text "in a constraint" + +wildCardsAllowed :: RnTyKiEnv -> Bool +-- ^ In what contexts are wildcards permitted +wildCardsAllowed env + = case rtke_ctxt env of + TypeSigCtx {} -> True + TypBrCtx {} -> True -- Template Haskell quoted type + SpliceTypeCtx {} -> True -- Result of a Template Haskell splice + ExprWithTySigCtx {} -> True + PatCtx {} -> True + RuleCtx {} -> True + FamPatCtx {} -> True -- Not named wildcards though + GHCiCtx {} -> True + HsTypeCtx {} -> True + StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls + _ -> False + + + +--------------- +-- | Ensures either that we're in a type or that -XPolyKinds is set +checkPolyKinds :: Outputable ty + => RnTyKiEnv + -> ty -- ^ type + -> RnM () +checkPolyKinds env ty + | isRnKindLevel env + = do { polykinds <- xoptM LangExt.PolyKinds + ; unless polykinds $ + addErr (text "Illegal kind:" <+> ppr ty $$ + text "Did you mean to enable PolyKinds?") } +checkPolyKinds _ _ = return () + +notInKinds :: Outputable ty + => RnTyKiEnv + -> ty + -> RnM () +notInKinds env ty + | isRnKindLevel env + = addErr (text "Illegal kind:" <+> ppr ty) +notInKinds _ _ = return () + +{- ***************************************************** +* * + Binding type variables +* * +***************************************************** -} + +bindSigTyVarsFV :: [Name] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +-- Used just before renaming the defn of a function +-- with a separate type signature, to bring its tyvars into scope +-- With no -XScopedTypeVariables, this is a no-op +bindSigTyVarsFV tvs thing_inside + = do { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables + ; if not scoped_tyvars then + thing_inside + else + bindLocalNamesFV tvs thing_inside } + +-- | Simply bring a bunch of RdrNames into scope. No checking for +-- validity, at all. The binding location is taken from the location +-- on each name. +bindLRdrNames :: [Located RdrName] + -> ([Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindLRdrNames rdrs thing_inside + = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs + ; bindLocalNamesFV var_names $ + thing_inside var_names } + +--------------- +bindHsQTyVars :: forall a b. + HsDocContext + -> Maybe SDoc -- Just d => check for unused tvs + -- d is a phrase like "in the type ..." + -> Maybe a -- Just _ => an associated type decl + -> [Located RdrName] -- Kind variables from scope, no dups + -> (LHsQTyVars GhcPs) + -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars)) + -- The Bool is True <=> all kind variables used in the + -- kind signature are bound on the left. Reason: + -- the last clause of Note [CUSKs: Complete user-supplied + -- kind signatures] in GHC.Hs.Decls + -> RnM (b, FreeVars) + +-- See Note [bindHsQTyVars examples] +-- (a) Bring kind variables into scope +-- both (i) passed in body_kv_occs +-- and (ii) mentioned in the kinds of hsq_bndrs +-- (b) Bring type variables into scope +-- +bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside + = do { let hs_tv_bndrs = hsQTvExplicit hsq_bndrs + bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs + + ; let -- See Note [bindHsQTyVars examples] for what + -- all these various things are doing + bndrs, kv_occs, implicit_kvs :: [Located RdrName] + bndrs = map hsLTyVarLocName hs_tv_bndrs + kv_occs = nubL (bndr_kv_occs ++ body_kv_occs) + -- Make sure to list the binder kvs before the + -- body kvs, as mandated by + -- Note [Ordering of implicit variables] + implicit_kvs = filter_occs bndrs kv_occs + del = deleteBys eqLocated + all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs) + + ; traceRn "checkMixedVars3" $ + vcat [ text "kv_occs" <+> ppr kv_occs + , text "bndrs" <+> ppr hs_tv_bndrs + , text "bndr_kv_occs" <+> ppr bndr_kv_occs + , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs) + ] + + ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs + + ; bindLocalNamesFV implicit_kv_nms $ + bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs -> + do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs) + ; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms + , hsq_explicit = rn_bndrs }) + all_bound_on_lhs } } + + where + filter_occs :: [Located RdrName] -- Bound here + -> [Located RdrName] -- Potential implicit binders + -> [Located RdrName] -- Final implicit binders + -- Filter out any potential implicit binders that are either + -- already in scope, or are explicitly bound in the same HsQTyVars + filter_occs bndrs occs + = filterOut is_in_scope occs + where + is_in_scope locc = locc `elemRdr` bndrs + +{- Note [bindHsQTyVars examples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + data T k (a::k1) (b::k) :: k2 -> k1 -> * + +Then: + hs_tv_bndrs = [k, a::k1, b::k], the explicitly-bound variables + bndrs = [k,a,b] + + bndr_kv_occs = [k,k1], kind variables free in kind signatures + of hs_tv_bndrs + + body_kv_occs = [k2,k1], kind variables free in the + result kind signature + + implicit_kvs = [k1,k2], kind variables free in kind signatures + of hs_tv_bndrs, and not bound by bndrs + +* We want to quantify add implicit bindings for implicit_kvs + +* If implicit_body_kvs is non-empty, then there is a kind variable + mentioned in the kind signature that is not bound "on the left". + That's one of the rules for a CUSK, so we pass that info on + as the second argument to thing_inside. + +* Order is not important in these lists. All we are doing is + bring Names into scope. + +Finally, you may wonder why filter_occs removes in-scope variables +from bndr/body_kv_occs. How can anything be in scope? Answer: +HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax +ConDecls + data T a = forall (b::k). MkT a b +The ConDecl has a LHsQTyVars in it; but 'a' scopes over the entire +ConDecl. Hence the local RdrEnv may be non-empty and we must filter +out 'a' from the free vars. (Mind you, in this situation all the +implicit kind variables are bound at the data type level, so there +are none to bind in the ConDecl, so there are no implicitly bound +variables at all. + +Note [Kind variable scoping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + data T (a :: k) k = ... +we report "k is out of scope" for (a::k). Reason: k is not brought +into scope until the explicit k-binding that follows. It would be +terribly confusing to bring into scope an /implicit/ k for a's kind +and a distinct, shadowing explicit k that follows, something like + data T {k1} (a :: k1) k = ... + +So the rule is: + + the implicit binders never include any + of the explicit binders in the group + +Note that in the denerate case + data T (a :: a) = blah +we get a complaint the second 'a' is not in scope. + +That applies to foralls too: e.g. + forall (a :: k) k . blah + +But if the foralls are split, we treat the two groups separately: + forall (a :: k). forall k. blah +Here we bring into scope an implicit k, which is later shadowed +by the explicit k. + +In implementation terms + +* In bindHsQTyVars 'k' is free in bndr_kv_occs; then we delete + the binders {a,k}, and so end with no implicit binders. Then we + rename the binders left-to-right, and hence see that 'k' is out of + scope in the kind of 'a'. + +* Similarly in extract_hs_tv_bndrs + +Note [Variables used as both types and kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We bind the type variables tvs, and kvs is the set of free variables of the +kinds in the scope of the binding. Here is one typical example: + + forall a b. a -> (b::k) -> (c::a) + +Here, tvs will be {a,b}, and kvs {k,a}. + +We must make sure that kvs includes all of variables in the kinds of type +variable bindings. For instance: + + forall k (a :: k). Proxy a + +If we only look in the body of the `forall` type, we will mistakenly conclude +that kvs is {}. But in fact, the type variable `k` is also used as a kind +variable in (a :: k), later in the binding. (This mistake lead to #14710.) +So tvs is {k,a} and kvs is {k}. + +NB: we do this only at the binding site of 'tvs'. +-} + +bindLHsTyVarBndrs :: HsDocContext + -> Maybe SDoc -- Just d => check for unused tvs + -- d is a phrase like "in the type ..." + -> Maybe a -- Just _ => an associated type decl + -> [LHsTyVarBndr GhcPs] -- User-written tyvars + -> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside + = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) + ; checkDupRdrNames tv_names_w_loc + ; go tv_bndrs thing_inside } + where + tv_names_w_loc = map hsLTyVarLocName tv_bndrs + + go [] thing_inside = thing_inside [] + go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' -> + do { (res, fvs) <- go bs $ \ bs' -> + thing_inside (b' : bs') + ; warn_unused b' fvs + ; return (res, fvs) } + + warn_unused tv_bndr fvs = case mb_in_doc of + Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs + Nothing -> return () + +bindLHsTyVarBndr :: HsDocContext + -> Maybe a -- associated class + -> LHsTyVarBndr GhcPs + -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +bindLHsTyVarBndr _doc mb_assoc (L loc + (UserTyVar x + lrdr@(L lv _))) thing_inside + = do { nm <- newTyVarNameRn mb_assoc lrdr + ; bindLocalNamesFV [nm] $ + thing_inside (L loc (UserTyVar x (L lv nm))) } + +bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind)) + thing_inside + = do { sig_ok <- xoptM LangExt.KindSignatures + ; unless sig_ok (badKindSigErr doc kind) + ; (kind', fvs1) <- rnLHsKind doc kind + ; tv_nm <- newTyVarNameRn mb_assoc lrdr + ; (b, fvs2) <- bindLocalNamesFV [tv_nm] + $ thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind')) + ; return (b, fvs1 `plusFV` fvs2) } + +bindLHsTyVarBndr _ _ (L _ (XTyVarBndr nec)) _ = noExtCon nec + +newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name +newTyVarNameRn mb_assoc (L loc rdr) + = do { rdr_env <- getLocalRdrEnv + ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of + (Just _, Just n) -> return n + -- Use the same Name as the parent class decl + + _ -> newLocalBndrRn (L loc rdr) } +{- +********************************************************* +* * + ConDeclField +* * +********************************************************* + +When renaming a ConDeclField, we have to find the FieldLabel +associated with each field. But we already have all the FieldLabels +available (since they were brought into scope by +GHC.Rename.Names.getLocalNonValBinders), so we just take the list as an +argument, build a map and look them up. +-} + +rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs] + -> RnM ([LConDeclField GhcRn], FreeVars) +-- Also called from GHC.Rename.Source +-- No wildcards can appear in record fields +rnConDeclFields ctxt fls fields + = mapFvRn (rnField fl_env env) fields + where + env = mkTyKiEnv ctxt TypeLevel RnTypeBody + fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ] + +rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs + -> RnM (LConDeclField GhcRn, FreeVars) +rnField fl_env env (L l (ConDeclField _ names ty haddock_doc)) + = do { let new_names = map (fmap lookupField) names + ; (new_ty, fvs) <- rnLHsTyKi env ty + ; new_haddock_doc <- rnMbLHsDoc haddock_doc + ; return (L l (ConDeclField noExtField new_names new_ty new_haddock_doc) + , fvs) } + where + lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn + lookupField (FieldOcc _ (L lr rdr)) = + FieldOcc (flSelector fl) (L lr rdr) + where + lbl = occNameFS $ rdrNameOcc rdr + fl = expectJust "rnField" $ lookupFsEnv fl_env lbl + lookupField (XFieldOcc nec) = noExtCon nec +rnField _ _ (L _ (XConDeclField nec)) = noExtCon nec + +{- +************************************************************************ +* * + Fixities and precedence parsing +* * +************************************************************************ + +@mkOpAppRn@ deals with operator fixities. The argument expressions +are assumed to be already correctly arranged. It needs the fixities +recorded in the OpApp nodes, because fixity info applies to the things +the programmer actually wrote, so you can't find it out from the Name. + +Furthermore, the second argument is guaranteed not to be another +operator application. Why? Because the parser parses all +operator applications left-associatively, EXCEPT negation, which +we need to handle specially. +Infix types are read in a *right-associative* way, so that + a `op` b `op` c +is always read in as + a `op` (b `op` c) + +mkHsOpTyRn rearranges where necessary. The two arguments +have already been renamed and rearranged. It's made rather tiresome +by the presence of ->, which is a separate syntactic construct. +-} + +--------------- +-- Building (ty1 `op1` (ty21 `op2` ty22)) +mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) + -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn + -> RnM (HsType GhcRn) + +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExtField ty21 op2 ty22)) + = do { fix2 <- lookupTyFixityRn op2 + ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 + (\t1 t2 -> HsOpTy noExtField t1 op2 t2) + (unLoc op2) fix2 ty21 ty22 loc2 } + +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22)) + = mk_hs_op_ty mk1 pp_op1 fix1 ty1 + (HsFunTy noExtField) funTyConName funTyFixity ty21 ty22 loc2 + +mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment + = return (mk1 ty1 ty2) + +--------------- +mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) + -> Name -> Fixity -> LHsType GhcRn + -> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) + -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan + -> RnM (HsType GhcRn) +mk_hs_op_ty mk1 op1 fix1 ty1 + mk2 op2 fix2 ty21 ty22 loc2 + | nofix_error = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2) + ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) } + | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) + | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) + new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21 + ; return (mk2 (noLoc new_ty) ty22) } + where + (nofix_error, associate_right) = compareFixity fix1 fix2 + + +--------------------------- +mkOpAppRn :: LHsExpr GhcRn -- Left operand; already rearranged + -> LHsExpr GhcRn -> Fixity -- Operator and fixity + -> LHsExpr GhcRn -- Right operand (not an OpApp, but might + -- be a NegApp) + -> RnM (HsExpr GhcRn) + +-- (e11 `op1` e12) `op2` e2 +mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2 + | nofix_error + = do precParseErr (get_op op1,fix1) (get_op op2,fix2) + return (OpApp fix2 e1 op2 e2) + + | associate_right = do + new_e <- mkOpAppRn e12 op2 fix2 e2 + return (OpApp fix1 e11 op1 (L loc' new_e)) + where + loc'= combineLocs e12 e2 + (nofix_error, associate_right) = compareFixity fix1 fix2 + +--------------------------- +-- (- neg_arg) `op` e2 +mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2 + | nofix_error + = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2) + return (OpApp fix2 e1 op2 e2) + + | associate_right + = do new_e <- mkOpAppRn neg_arg op2 fix2 e2 + return (NegApp noExtField (L loc' new_e) neg_name) + where + loc' = combineLocs neg_arg e2 + (nofix_error, associate_right) = compareFixity negateFixity fix2 + +--------------------------- +-- e1 `op` - neg_arg +mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right + | not associate_right -- We *want* right association + = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity) + return (OpApp fix1 e1 op1 e2) + where + (_, associate_right) = compareFixity fix1 negateFixity + +--------------------------- +-- Default case +mkOpAppRn e1 op fix e2 -- Default case, no rearrangment + = ASSERT2( right_op_ok fix (unLoc e2), + ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 + ) + return (OpApp fix e1 op e2) + +---------------------------- + +-- | Name of an operator in an operator application or section +data OpName = NormalOp Name -- ^ A normal identifier + | NegateOp -- ^ Prefix negation + | UnboundOp OccName -- ^ An unbound indentifier + | RecFldOp (AmbiguousFieldOcc GhcRn) + -- ^ A (possibly ambiguous) record field occurrence + +instance Outputable OpName where + ppr (NormalOp n) = ppr n + ppr NegateOp = ppr negateName + ppr (UnboundOp uv) = ppr uv + ppr (RecFldOp fld) = ppr fld + +get_op :: LHsExpr GhcRn -> OpName +-- An unbound name could be either HsVar or HsUnboundVar +-- See GHC.Rename.Expr.rnUnboundVar +get_op (L _ (HsVar _ n)) = NormalOp (unLoc n) +get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv +get_op (L _ (HsRecFld _ fld)) = RecFldOp fld +get_op other = pprPanic "get_op" (ppr other) + +-- Parser left-associates everything, but +-- derived instances may have correctly-associated things to +-- in the right operand. So we just check that the right operand is OK +right_op_ok :: Fixity -> HsExpr GhcRn -> Bool +right_op_ok fix1 (OpApp fix2 _ _ _) + = not error_please && associate_right + where + (error_please, associate_right) = compareFixity fix1 fix2 +right_op_ok _ _ + = True + +-- Parser initially makes negation bind more tightly than any other operator +-- And "deriving" code should respect this (use HsPar if not) +mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id) + -> RnM (HsExpr (GhcPass id)) +mkNegAppRn neg_arg neg_name + = ASSERT( not_op_app (unLoc neg_arg) ) + return (NegApp noExtField neg_arg neg_name) + +not_op_app :: HsExpr id -> Bool +not_op_app (OpApp {}) = False +not_op_app _ = True + +--------------------------- +mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged + -> LHsExpr GhcRn -> Fixity -- Operator and fixity + -> LHsCmdTop GhcRn -- Right operand (not an infix) + -> RnM (HsCmd GhcRn) + +-- (e11 `op1` e12) `op2` e2 +mkOpFormRn a1@(L loc + (HsCmdTop _ + (L _ (HsCmdArrForm x op1 f (Just fix1) + [a11,a12])))) + op2 fix2 a2 + | nofix_error + = do precParseErr (get_op op1,fix1) (get_op op2,fix2) + return (HsCmdArrForm x op2 f (Just fix2) [a1, a2]) + + | associate_right + = do new_c <- mkOpFormRn a12 op2 fix2 a2 + return (HsCmdArrForm noExtField op1 f (Just fix1) + [a11, L loc (HsCmdTop [] (L loc new_c))]) + -- TODO: locs are wrong + where + (nofix_error, associate_right) = compareFixity fix1 fix2 + +-- Default case +mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment + = return (HsCmdArrForm noExtField op Infix (Just fix) [arg1, arg2]) + + +-------------------------------------- +mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn + -> RnM (Pat GhcRn) + +mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 + = do { fix1 <- lookupFixityRn (unLoc op1) + ; let (nofix_error, associate_right) = compareFixity fix1 fix2 + + ; if nofix_error then do + { precParseErr (NormalOp (unLoc op1),fix1) + (NormalOp (unLoc op2),fix2) + ; return (ConPatIn op2 (InfixCon p1 p2)) } + + else if associate_right then do + { new_p <- mkConOpPatRn op2 fix2 p12 p2 + ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } + -- XXX loc right? + else return (ConPatIn op2 (InfixCon p1 p2)) } + +mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment + = ASSERT( not_op_pat (unLoc p2) ) + return (ConPatIn op (InfixCon p1 p2)) + +not_op_pat :: Pat GhcRn -> Bool +not_op_pat (ConPatIn _ (InfixCon _ _)) = False +not_op_pat _ = True + +-------------------------------------- +checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM () + -- Check precedence of a function binding written infix + -- eg a `op` b `C` c = ... + -- See comments with rnExpr (OpApp ...) about "deriving" + +checkPrecMatch op (MG { mg_alts = (L _ ms) }) + = mapM_ check ms + where + check (L _ (Match { m_pats = (L l1 p1) + : (L l2 p2) + : _ })) + = setSrcSpan (combineSrcSpans l1 l2) $ + do checkPrec op p1 False + checkPrec op p2 True + + check _ = return () + -- This can happen. Consider + -- a `op` True = ... + -- op = ... + -- The infix flag comes from the first binding of the group + -- but the second eqn has no args (an error, but not discovered + -- until the type checker). So we don't want to crash on the + -- second eqn. +checkPrecMatch _ (XMatchGroup nec) = noExtCon nec + +checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () +checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do + op_fix@(Fixity _ op_prec op_dir) <- lookupFixityRn op + op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1) + let + inf_ok = op1_prec > op_prec || + (op1_prec == op_prec && + (op1_dir == InfixR && op_dir == InfixR && right || + op1_dir == InfixL && op_dir == InfixL && not right)) + + info = (NormalOp op, op_fix) + info1 = (NormalOp (unLoc op1), op1_fix) + (infol, infor) = if right then (info, info1) else (info1, info) + unless inf_ok (precParseErr infol infor) + +checkPrec _ _ _ + = return () + +-- Check precedence of (arg op) or (op arg) respectively +-- If arg is itself an operator application, then either +-- (a) its precedence must be higher than that of op +-- (b) its precedency & associativity must be the same as that of op +checkSectionPrec :: FixityDirection -> HsExpr GhcPs + -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM () +checkSectionPrec direction section op arg + = case unLoc arg of + OpApp fix _ op' _ -> go_for_it (get_op op') fix + NegApp _ _ _ -> go_for_it NegateOp negateFixity + _ -> return () + where + op_name = get_op op + go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do + op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name + unless (op_prec < arg_prec + || (op_prec == arg_prec && direction == assoc)) + (sectionPrecErr (get_op op, op_fix) + (arg_op, arg_fix) section) + +-- | Look up the fixity for an operator name. Be careful to use +-- 'lookupFieldFixityRn' for (possibly ambiguous) record fields +-- (see #13132). +lookupFixityOp :: OpName -> RnM Fixity +lookupFixityOp (NormalOp n) = lookupFixityRn n +lookupFixityOp NegateOp = lookupFixityRn negateName +lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName u) +lookupFixityOp (RecFldOp f) = lookupFieldFixityRn f + + +-- Precedence-related error messages + +precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM () +precParseErr op1@(n1,_) op2@(n2,_) + | is_unbound n1 || is_unbound n2 + = return () -- Avoid error cascade + | otherwise + = addErr $ hang (text "Precedence parsing error") + 4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"), + ppr_opfix op2, + text "in the same infix expression"]) + +sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM () +sectionPrecErr op@(n1,_) arg_op@(n2,_) section + | is_unbound n1 || is_unbound n2 + = return () -- Avoid error cascade + | otherwise + = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"), + nest 4 (sep [text "must have lower precedence than that of the operand,", + nest 2 (text "namely" <+> ppr_opfix arg_op)]), + nest 4 (text "in the section:" <+> quotes (ppr section))] + +is_unbound :: OpName -> Bool +is_unbound (NormalOp n) = isUnboundName n +is_unbound UnboundOp{} = True +is_unbound _ = False + +ppr_opfix :: (OpName, Fixity) -> SDoc +ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) + where + pp_op | NegateOp <- op = text "prefix `-'" + | otherwise = quotes (ppr op) + + +{- ***************************************************** +* * + Errors +* * +***************************************************** -} + +unexpectedTypeSigErr :: LHsSigWcType GhcPs -> SDoc +unexpectedTypeSigErr ty + = hang (text "Illegal type signature:" <+> quotes (ppr ty)) + 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") + +badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () +badKindSigErr doc (L loc ty) + = setSrcSpan loc $ addErr $ + withHsDocContext doc $ + hang (text "Illegal kind signature:" <+> quotes (ppr ty)) + 2 (text "Perhaps you intended to use KindSignatures") + +dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc +dataKindsErr env thing + = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing)) + 2 (text "Perhaps you intended to use DataKinds") + where + pp_what | isRnKindLevel env = text "kind" + | otherwise = text "type" + +inTypeDoc :: HsType GhcPs -> SDoc +inTypeDoc ty = text "In the type" <+> quotes (ppr ty) + +warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM () +warnUnusedForAll in_doc (L loc tv) used_names + = whenWOptM Opt_WarnUnusedForalls $ + unless (hsTyVarName tv `elemNameSet` used_names) $ + addWarnAt (Reason Opt_WarnUnusedForalls) loc $ + vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) + , in_doc ] + +opTyErr :: Outputable a => RdrName -> a -> SDoc +opTyErr op overall_ty + = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty)) + 2 (text "Use TypeOperators to allow operators in types") + +{- +************************************************************************ +* * + Finding the free type variables of a (HsType RdrName) +* * +************************************************************************ + + +Note [Kind and type-variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a type signature we may implicitly bind type/kind variables. For example: + * f :: a -> a + f = ... + Here we need to find the free type variables of (a -> a), + so that we know what to quantify + + * class C (a :: k) where ... + This binds 'k' in ..., as well as 'a' + + * f (x :: a -> [a]) = .... + Here we bind 'a' in .... + + * f (x :: T a -> T (b :: k)) = ... + Here we bind both 'a' and the kind variable 'k' + + * type instance F (T (a :: Maybe k)) = ...a...k... + Here we want to constrain the kind of 'a', and bind 'k'. + +To do that, we need to walk over a type and find its free type/kind variables. +We preserve the left-to-right order of each variable occurrence. +See Note [Ordering of implicit variables]. + +Clients of this code can remove duplicates with nubL. + +Note [Ordering of implicit variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the advent of -XTypeApplications, GHC makes promises about the ordering +of implicit variable quantification. Specifically, we offer that implicitly +quantified variables (such as those in const :: a -> b -> a, without a `forall`) +will occur in left-to-right order of first occurrence. Here are a few examples: + + const :: a -> b -> a -- forall a b. ... + f :: Eq a => b -> a -> a -- forall a b. ... contexts are included + + type a <-< b = b -> a + g :: a <-< b -- forall a b. ... type synonyms matter + + class Functor f where + fmap :: (a -> b) -> f a -> f b -- forall f a b. ... + -- The f is quantified by the class, so only a and b are considered in fmap + +This simple story is complicated by the possibility of dependency: all variables +must come after any variables mentioned in their kinds. + + typeRep :: Typeable a => TypeRep (a :: k) -- forall k a. ... + +The k comes first because a depends on k, even though the k appears later than +the a in the code. Thus, GHC does ScopedSort on the variables. +See Note [ScopedSort] in Type. + +Implicitly bound variables are collected by any function which returns a +FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably +includes the `extract-` family of functions (extractHsTysRdrTyVarsDups, +extractHsTyVarBndrsKVs, etc.). +These functions thus promise to keep left-to-right ordering. + +Note [Implicit quantification in type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We typically bind type/kind variables implicitly when they are in a kind +annotation on the LHS, for example: + + data Proxy (a :: k) = Proxy + type KindOf (a :: k) = k + +Here 'k' is in the kind annotation of a type variable binding, KindedTyVar, and +we want to implicitly quantify over it. This is easy: just extract all free +variables from the kind signature. That's what we do in extract_hs_tv_bndrs_kvs + +By contrast, on the RHS we can't simply collect *all* free variables. Which of +the following are allowed? + + type TySyn1 = a :: Type + type TySyn2 = 'Nothing :: Maybe a + type TySyn3 = 'Just ('Nothing :: Maybe a) + type TySyn4 = 'Left a :: Either Type a + +After some design deliberations (see non-taken alternatives below), the answer +is to reject TySyn1 and TySyn3, but allow TySyn2 and TySyn4, at least for now. +We implicitly quantify over free variables of the outermost kind signature, if +one exists: + + * In TySyn1, the outermost kind signature is (:: Type), and it does not have + any free variables. + * In TySyn2, the outermost kind signature is (:: Maybe a), it contains a + free variable 'a', which we implicitly quantify over. + * In TySyn3, there is no outermost kind signature. The (:: Maybe a) signature + is hidden inside 'Just. + * In TySyn4, the outermost kind signature is (:: Either Type a), it contains + a free variable 'a', which we implicitly quantify over. That is why we can + also use it to the left of the double colon: 'Left a + +The logic resides in extractHsTyRdrTyVarsKindVars. We use it both for type +synonyms and type family instances. + +This is something of a stopgap solution until we can explicitly bind invisible +type/kind variables: + + type TySyn3 :: forall a. Maybe a + type TySyn3 @a = 'Just ('Nothing :: Maybe a) + +Note [Implicit quantification in type synonyms: non-taken alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Alternative I: No quantification +-------------------------------- +We could offer no implicit quantification on the RHS, accepting none of the +TySyn<N> examples. The user would have to bind the variables explicitly: + + type TySyn1 a = a :: Type + type TySyn2 a = 'Nothing :: Maybe a + type TySyn3 a = 'Just ('Nothing :: Maybe a) + type TySyn4 a = 'Left a :: Either Type a + +However, this would mean that one would have to specify 'a' at call sites every +time, which could be undesired. + +Alternative II: Indiscriminate quantification +--------------------------------------------- +We could implicitly quantify over all free variables on the RHS just like we do +on the LHS. Then we would infer the following kinds: + + TySyn1 :: forall {a}. Type + TySyn2 :: forall {a}. Maybe a + TySyn3 :: forall {a}. Maybe (Maybe a) + TySyn4 :: forall {a}. Either Type a + +This would work fine for TySyn<2,3,4>, but TySyn1 is clearly bogus: the variable +is free-floating, not fixed by anything. + +Alternative III: reportFloatingKvs +---------------------------------- +We could augment Alternative II by hunting down free-floating variables during +type checking. While viable, this would mean we'd end up accepting this: + + data Prox k (a :: k) + type T = Prox k + +-} + +-- See Note [Kind and type-variable binders] +-- These lists are guaranteed to preserve left-to-right ordering of +-- the types the variables were extracted from. See also +-- Note [Ordering of implicit variables]. +type FreeKiTyVars = [Located RdrName] + +-- | A 'FreeKiTyVars' list that is allowed to have duplicate variables. +type FreeKiTyVarsWithDups = FreeKiTyVars + +-- | A 'FreeKiTyVars' list that contains no duplicate variables. +type FreeKiTyVarsNoDups = FreeKiTyVars + +filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars +filterInScope rdr_env = filterOut (inScope rdr_env . unLoc) + +filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars +filterInScopeM vars + = do { rdr_env <- getLocalRdrEnv + ; return (filterInScope rdr_env vars) } + +inScope :: LocalRdrEnv -> RdrName -> Bool +inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env + +extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups +extract_tyarg (HsValArg ty) acc = extract_lty ty acc +extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc +extract_tyarg (HsArgPar _) acc = acc + +extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups +extract_tyargs args acc = foldr extract_tyarg acc args + +extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups +extractHsTyArgRdrKiTyVarsDup args + = extract_tyargs args [] + +-- | 'extractHsTyRdrTyVars' finds the type/kind variables +-- of a HsType/HsKind. +-- It's used when making the @forall@s explicit. +-- When the same name occurs multiple times in the types, only the first +-- occurrence is returned. +-- See Note [Kind and type-variable binders] +extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsNoDups +extractHsTyRdrTyVars ty + = nubL (extractHsTyRdrTyVarsDups ty) + +-- | 'extractHsTyRdrTyVarsDups' finds the type/kind variables +-- of a HsType/HsKind. +-- It's used when making the @forall@s explicit. +-- When the same name occurs multiple times in the types, all occurrences +-- are returned. +extractHsTyRdrTyVarsDups :: LHsType GhcPs -> FreeKiTyVarsWithDups +extractHsTyRdrTyVarsDups ty + = extract_lty ty [] + +-- | Extracts the free type/kind variables from the kind signature of a HsType. +-- This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k@. +-- When the same name occurs multiple times in the type, only the first +-- occurrence is returned, and the left-to-right order of variables is +-- preserved. +-- See Note [Kind and type-variable binders] and +-- Note [Ordering of implicit variables] and +-- Note [Implicit quantification in type synonyms]. +extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVarsNoDups +extractHsTyRdrTyVarsKindVars (unLoc -> ty) = + case ty of + HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty + HsKindSig _ _ ki -> extractHsTyRdrTyVars ki + _ -> [] + +-- | Extracts free type and kind variables from types in a list. +-- When the same name occurs multiple times in the types, all occurrences +-- are returned. +extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> FreeKiTyVarsWithDups +extractHsTysRdrTyVarsDups tys + = extract_ltys tys [] + +-- Returns the free kind variables of any explicitly-kinded binders, returning +-- variable occurrences in left-to-right order. +-- See Note [Ordering of implicit variables]. +-- NB: Does /not/ delete the binders themselves. +-- However duplicates are removed +-- E.g. given [k1, a:k1, b:k2] +-- the function returns [k1,k2], even though k1 is bound here +extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsNoDups +extractHsTyVarBndrsKVs tv_bndrs + = nubL (extract_hs_tv_bndrs_kvs tv_bndrs) + +-- Returns the free kind variables in a type family result signature, returning +-- variable occurrences in left-to-right order. +-- See Note [Ordering of implicit variables]. +extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName] +extractRdrKindSigVars (L _ resultSig) + | KindSig _ k <- resultSig = extractHsTyRdrTyVars k + | TyVarSig _ (L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k + | otherwise = [] + +-- Get type/kind variables mentioned in the kind signature, preserving +-- left-to-right order and without duplicates: +-- +-- * data T a (b :: k1) :: k2 -> k1 -> k2 -> Type -- result: [k2,k1] +-- * data T a (b :: k1) -- result: [] +-- +-- See Note [Ordering of implicit variables]. +extractDataDefnKindVars :: HsDataDefn GhcPs -> FreeKiTyVarsNoDups +extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig }) + = maybe [] extractHsTyRdrTyVars ksig +extractDataDefnKindVars (XHsDataDefn nec) = noExtCon nec + +extract_lctxt :: LHsContext GhcPs + -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups +extract_lctxt ctxt = extract_ltys (unLoc ctxt) + +extract_ltys :: [LHsType GhcPs] + -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups +extract_ltys tys acc = foldr extract_lty acc tys + +extract_lty :: LHsType GhcPs + -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups +extract_lty (L _ ty) acc + = case ty of + HsTyVar _ _ ltv -> extract_tv ltv acc + HsBangTy _ _ ty -> extract_lty ty acc + HsRecTy _ flds -> foldr (extract_lty + . cd_fld_type . unLoc) acc + flds + HsAppTy _ ty1 ty2 -> extract_lty ty1 $ + extract_lty ty2 acc + HsAppKindTy _ ty k -> extract_lty ty $ + extract_lty k acc + HsListTy _ ty -> extract_lty ty acc + HsTupleTy _ _ tys -> extract_ltys tys acc + HsSumTy _ tys -> extract_ltys tys acc + HsFunTy _ ty1 ty2 -> extract_lty ty1 $ + extract_lty ty2 acc + HsIParamTy _ _ ty -> extract_lty ty acc + HsOpTy _ ty1 tv ty2 -> extract_tv tv $ + extract_lty ty1 $ + extract_lty ty2 acc + HsParTy _ ty -> extract_lty ty acc + HsSpliceTy {} -> acc -- Type splices mention no tvs + HsDocTy _ ty _ -> extract_lty ty acc + HsExplicitListTy _ _ tys -> extract_ltys tys acc + HsExplicitTupleTy _ tys -> extract_ltys tys acc + HsTyLit _ _ -> acc + HsStarTy _ _ -> acc + HsKindSig _ ty ki -> extract_lty ty $ + extract_lty ki acc + HsForAllTy { hst_bndrs = tvs, hst_body = ty } + -> extract_hs_tv_bndrs tvs acc $ + extract_lty ty [] + HsQualTy { hst_ctxt = ctxt, hst_body = ty } + -> extract_lctxt ctxt $ + extract_lty ty acc + XHsType {} -> acc + -- We deal with these separately in rnLHsTypeWithWildCards + HsWildCardTy {} -> acc + +extractHsTvBndrs :: [LHsTyVarBndr GhcPs] + -> FreeKiTyVarsWithDups -- Free in body + -> FreeKiTyVarsWithDups -- Free in result +extractHsTvBndrs tv_bndrs body_fvs + = extract_hs_tv_bndrs tv_bndrs [] body_fvs + +extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs] + -> FreeKiTyVarsWithDups -- Accumulator + -> FreeKiTyVarsWithDups -- Free in body + -> FreeKiTyVarsWithDups +-- In (forall (a :: Maybe e). a -> b) we have +-- 'a' is bound by the forall +-- 'b' is a free type variable +-- 'e' is a free kind variable +extract_hs_tv_bndrs tv_bndrs acc_vars body_vars + | null tv_bndrs = body_vars ++ acc_vars + | otherwise = filterOut (`elemRdr` tv_bndr_rdrs) (bndr_vars ++ body_vars) ++ acc_vars + -- NB: delete all tv_bndr_rdrs from bndr_vars as well as body_vars. + -- See Note [Kind variable scoping] + where + bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs + tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs + +extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName] +-- Returns the free kind variables of any explicitly-kinded binders, returning +-- variable occurrences in left-to-right order. +-- See Note [Ordering of implicit variables]. +-- NB: Does /not/ delete the binders themselves. +-- Duplicates are /not/ removed +-- E.g. given [k1, a:k1, b:k2] +-- the function returns [k1,k2], even though k1 is bound here +extract_hs_tv_bndrs_kvs tv_bndrs = + foldr extract_lty [] + [k | L _ (KindedTyVar _ _ k) <- tv_bndrs] + +extract_tv :: Located RdrName + -> [Located RdrName] -> [Located RdrName] +extract_tv tv acc = + if isRdrTyVar (unLoc tv) then tv:acc else acc + +-- Deletes duplicates in a list of Located things. +-- +-- Importantly, this function is stable with respect to the original ordering +-- of things in the list. This is important, as it is a property that GHC +-- relies on to maintain the left-to-right ordering of implicitly quantified +-- type variables. +-- See Note [Ordering of implicit variables]. +nubL :: Eq a => [Located a] -> [Located a] +nubL = nubBy eqLocated + +elemRdr :: Located RdrName -> [Located RdrName] -> Bool +elemRdr x = any (eqLocated x) diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs new file mode 100644 index 0000000000..f8b33aa748 --- /dev/null +++ b/compiler/GHC/Rename/Unbound.hs @@ -0,0 +1,384 @@ +{- + +This module contains helper functions for reporting and creating +unbound variables. + +-} +module GHC.Rename.Unbound + ( mkUnboundName + , mkUnboundNameRdr + , isUnboundName + , reportUnboundName + , unknownNameSuggestions + , WhereLooking(..) + , unboundName + , unboundNameX + , notInScopeErr + ) +where + +import GhcPrelude + +import RdrName +import HscTypes +import TcRnMonad +import Name +import Module +import SrcLoc +import Outputable +import PrelNames ( mkUnboundName, isUnboundName, getUnique) +import Util +import Maybes +import DynFlags +import FastString +import Data.List +import Data.Function ( on ) +import UniqDFM (udfmToList) + +{- +************************************************************************ +* * + What to do when a lookup fails +* * +************************************************************************ +-} + +data WhereLooking = WL_Any -- Any binding + | WL_Global -- Any top-level binding (local or imported) + | WL_LocalTop -- Any top-level binding in this module + | WL_LocalOnly + -- Only local bindings + -- (pattern synonyms declaractions, + -- see Note [Renaming pattern synonym variables]) + +mkUnboundNameRdr :: RdrName -> Name +mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr) + +reportUnboundName :: RdrName -> RnM Name +reportUnboundName rdr = unboundName WL_Any rdr + +unboundName :: WhereLooking -> RdrName -> RnM Name +unboundName wl rdr = unboundNameX wl rdr Outputable.empty + +unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name +unboundNameX where_look rdr_name extra + = do { dflags <- getDynFlags + ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags + err = notInScopeErr rdr_name $$ extra + ; if not show_helpful_errors + then addErr err + else do { local_env <- getLocalRdrEnv + ; global_env <- getGlobalRdrEnv + ; impInfo <- getImports + ; currmod <- getModule + ; hpt <- getHpt + ; let suggestions = unknownNameSuggestions_ where_look + dflags hpt currmod global_env local_env impInfo + rdr_name + ; addErr (err $$ suggestions) } + ; return (mkUnboundNameRdr rdr_name) } + +notInScopeErr :: RdrName -> SDoc +notInScopeErr rdr_name + = hang (text "Not in scope:") + 2 (what <+> quotes (ppr rdr_name)) + where + what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) + +type HowInScope = Either SrcSpan ImpDeclSpec + -- Left loc => locally bound at loc + -- Right ispec => imported as specified by ispec + + +-- | Called from the typechecker (TcErrors) when we find an unbound variable +unknownNameSuggestions :: DynFlags + -> HomePackageTable -> Module + -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails + -> RdrName -> SDoc +unknownNameSuggestions = unknownNameSuggestions_ WL_Any + +unknownNameSuggestions_ :: WhereLooking -> DynFlags + -> HomePackageTable -> Module + -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails + -> RdrName -> SDoc +unknownNameSuggestions_ where_look dflags hpt curr_mod global_env local_env + imports tried_rdr_name = + similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$ + importSuggestions where_look global_env hpt + curr_mod imports tried_rdr_name $$ + extensionSuggestions tried_rdr_name + + +similarNameSuggestions :: WhereLooking -> DynFlags + -> GlobalRdrEnv -> LocalRdrEnv + -> RdrName -> SDoc +similarNameSuggestions where_look dflags global_env + local_env tried_rdr_name + = case suggest of + [] -> Outputable.empty + [p] -> perhaps <+> pp_item p + ps -> sep [ perhaps <+> text "one of these:" + , nest 2 (pprWithCommas pp_item ps) ] + where + all_possibilities :: [(String, (RdrName, HowInScope))] + all_possibilities + = [ (showPpr dflags r, (r, Left loc)) + | (r,loc) <- local_possibilities local_env ] + ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ] + + suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities + perhaps = text "Perhaps you meant" + + pp_item :: (RdrName, HowInScope) -> SDoc + pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined + where loc' = case loc of + UnhelpfulSpan l -> parens (ppr l) + RealSrcSpan l -> parens (text "line" <+> int (srcSpanStartLine l)) + pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+> -- Imported + parens (text "imported from" <+> ppr (is_mod is)) + + pp_ns :: RdrName -> SDoc + pp_ns rdr | ns /= tried_ns = pprNameSpace ns + | otherwise = Outputable.empty + where ns = rdrNameSpace rdr + + tried_occ = rdrNameOcc tried_rdr_name + tried_is_sym = isSymOcc tried_occ + tried_ns = occNameSpace tried_occ + tried_is_qual = isQual tried_rdr_name + + correct_name_space occ = nameSpacesRelated (occNameSpace occ) tried_ns + && isSymOcc occ == tried_is_sym + -- Treat operator and non-operators as non-matching + -- This heuristic avoids things like + -- Not in scope 'f'; perhaps you meant '+' (from Prelude) + + local_ok = case where_look of { WL_Any -> True + ; WL_LocalOnly -> True + ; _ -> False } + local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)] + local_possibilities env + | tried_is_qual = [] + | not local_ok = [] + | otherwise = [ (mkRdrUnqual occ, nameSrcSpan name) + | name <- localRdrEnvElts env + , let occ = nameOccName name + , correct_name_space occ] + + global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))] + global_possibilities global_env + | tried_is_qual = [ (rdr_qual, (rdr_qual, how)) + | gre <- globalRdrEnvElts global_env + , isGreOk where_look gre + , let name = gre_name gre + occ = nameOccName name + , correct_name_space occ + , (mod, how) <- qualsInScope gre + , let rdr_qual = mkRdrQual mod occ ] + + | otherwise = [ (rdr_unqual, pair) + | gre <- globalRdrEnvElts global_env + , isGreOk where_look gre + , let name = gre_name gre + occ = nameOccName name + rdr_unqual = mkRdrUnqual occ + , correct_name_space occ + , pair <- case (unquals_in_scope gre, quals_only gre) of + (how:_, _) -> [ (rdr_unqual, how) ] + ([], pr:_) -> [ pr ] -- See Note [Only-quals] + ([], []) -> [] ] + + -- Note [Only-quals] + -- The second alternative returns those names with the same + -- OccName as the one we tried, but live in *qualified* imports + -- e.g. if you have: + -- + -- > import qualified Data.Map as Map + -- > foo :: Map + -- + -- then we suggest @Map.Map@. + + -------------------- + unquals_in_scope :: GlobalRdrElt -> [HowInScope] + unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }) + | lcl = [ Left (nameSrcSpan n) ] + | otherwise = [ Right ispec + | i <- is, let ispec = is_decl i + , not (is_qual ispec) ] + + + -------------------- + quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)] + -- Ones for which *only* the qualified version is in scope + quals_only (GRE { gre_name = n, gre_imp = is }) + = [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec) + | i <- is, let ispec = is_decl i, is_qual ispec ] + +-- | Generate helpful suggestions if a qualified name Mod.foo is not in scope. +importSuggestions :: WhereLooking + -> GlobalRdrEnv + -> HomePackageTable -> Module + -> ImportAvails -> RdrName -> SDoc +importSuggestions where_look global_env hpt currMod imports rdr_name + | WL_LocalOnly <- where_look = Outputable.empty + | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty + | null interesting_imports + , Just name <- mod_name + , show_not_imported_line name + = hsep + [ text "No module named" + , quotes (ppr name) + , text "is imported." + ] + | is_qualified + , null helpful_imports + , [(mod,_)] <- interesting_imports + = hsep + [ text "Module" + , quotes (ppr mod) + , text "does not export" + , quotes (ppr occ_name) <> dot + ] + | is_qualified + , null helpful_imports + , not (null interesting_imports) + , mods <- map fst interesting_imports + = hsep + [ text "Neither" + , quotedListWithNor (map ppr mods) + , text "exports" + , quotes (ppr occ_name) <> dot + ] + | [(mod,imv)] <- helpful_imports_non_hiding + = fsep + [ text "Perhaps you want to add" + , quotes (ppr occ_name) + , text "to the import list" + , text "in the import of" + , quotes (ppr mod) + , parens (ppr (imv_span imv)) <> dot + ] + | not (null helpful_imports_non_hiding) + = fsep + [ text "Perhaps you want to add" + , quotes (ppr occ_name) + , text "to one of these import lists:" + ] + $$ + nest 2 (vcat + [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) + | (mod,imv) <- helpful_imports_non_hiding + ]) + | [(mod,imv)] <- helpful_imports_hiding + = fsep + [ text "Perhaps you want to remove" + , quotes (ppr occ_name) + , text "from the explicit hiding list" + , text "in the import of" + , quotes (ppr mod) + , parens (ppr (imv_span imv)) <> dot + ] + | not (null helpful_imports_hiding) + = fsep + [ text "Perhaps you want to remove" + , quotes (ppr occ_name) + , text "from the hiding clauses" + , text "in one of these imports:" + ] + $$ + nest 2 (vcat + [ quotes (ppr mod) <+> parens (ppr (imv_span imv)) + | (mod,imv) <- helpful_imports_hiding + ]) + | otherwise + = Outputable.empty + where + is_qualified = isQual 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" + + + -- What import statements provide "Mod" at all + -- or, if this is an unqualified name, are not qualified imports + interesting_imports = [ (mod, imp) + | (mod, mod_imports) <- moduleEnvToList (imp_mods imports) + , Just imp <- return $ pick (importedByUser mod_imports) + ] + + -- We want to keep only one for each original module; preferably one with an + -- explicit import list (for no particularly good reason) + pick :: [ImportedModsVal] -> Maybe ImportedModsVal + pick = listToMaybe . sortBy (compare `on` prefer) . filter select + where select imv = case mod_name of Just name -> imv_name imv == name + Nothing -> not (imv_qualified imv) + prefer imv = (imv_is_hiding imv, imv_span imv) + + -- Which of these would export a 'foo' + -- (all of these are restricted imports, because if they were not, we + -- wouldn't have an out-of-scope error in the first place) + helpful_imports = filter helpful interesting_imports + where helpful (_,imv) + = not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name + + -- Which of these do that because of an explicit hiding list resp. an + -- explicit import list + (helpful_imports_hiding, helpful_imports_non_hiding) + = partition (imv_is_hiding . snd) helpful_imports + + -- See note [When to show/hide the module-not-imported line] + show_not_imported_line :: ModuleName -> Bool -- #15611 + show_not_imported_line modnam + | modnam `elem` globMods = False -- #14225 -- 1 + | moduleName currMod == modnam = False -- 2.1 + | is_last_loaded_mod modnam hpt_uniques = False -- 2.2 + | otherwise = True + where + hpt_uniques = map fst (udfmToList hpt) + is_last_loaded_mod _ [] = False + is_last_loaded_mod modnam uniqs = last uniqs == getUnique modnam + globMods = nub [ mod + | gre <- globalRdrEnvElts global_env + , isGreOk where_look gre + , (mod, _) <- qualsInScope gre + ] + +extensionSuggestions :: RdrName -> SDoc +extensionSuggestions rdrName + | rdrName == mkUnqual varName (fsLit "mdo") || + rdrName == mkUnqual varName (fsLit "rec") + = text "Perhaps you meant to use RecursiveDo" + | otherwise = Outputable.empty + +qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)] +-- Ones for which the qualified version is in scope +qualsInScope GRE { gre_name = n, gre_lcl = lcl, gre_imp = is } + | lcl = case nameModule_maybe n of + Nothing -> [] + Just m -> [(moduleName m, Left (nameSrcSpan n))] + | otherwise = [ (is_as ispec, Right ispec) + | i <- is, let ispec = is_decl i ] + +isGreOk :: WhereLooking -> GlobalRdrElt -> Bool +isGreOk where_look = case where_look of + WL_LocalTop -> isLocalGRE + WL_LocalOnly -> const False + _ -> const True + +{- Note [When to show/hide the module-not-imported line] -- #15611 +For the error message: + Not in scope X.Y + Module X does not export Y + No module named ‘X’ is imported: +there are 2 cases, where we hide the last "no module is imported" line: +1. If the module X has been imported. +2. If the module X is the current module. There are 2 subcases: + 2.1 If the unknown module name is in a input source file, + then we can use the getModule function to get the current module name. + (See test T15611a) + 2.2 If the unknown module name has been entered by the user in GHCi, + then the getModule function returns something like "interactive:Ghci1", + and we have to check the current module in the last added entry of + the HomePackageTable. (See test T15611b) +-} diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs new file mode 100644 index 0000000000..b2d8fad31c --- /dev/null +++ b/compiler/GHC/Rename/Utils.hs @@ -0,0 +1,514 @@ +{- + +This module contains miscellaneous functions related to renaming. + +-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +module GHC.Rename.Utils ( + checkDupRdrNames, checkShadowedRdrNames, + checkDupNames, checkDupAndShadowedNames, dupNamesErr, + checkTupSize, + addFvRn, mapFvRn, mapMaybeFvRn, + warnUnusedMatches, warnUnusedTypePatterns, + warnUnusedTopBinds, warnUnusedLocalBinds, + checkUnusedRecordWildcard, + mkFieldEnv, + unknownSubordinateErr, badQualBndrErr, typeAppErr, + HsDocContext(..), pprHsDocContext, + inHsDocContext, withHsDocContext, + + newLocalBndrRn, newLocalBndrsRn, + + bindLocalNames, bindLocalNamesFV, + + addNameClashErrRn, extendTyVarEnvFVRn + +) + +where + + +import GhcPrelude + +import GHC.Hs +import RdrName +import HscTypes +import TcEnv +import TcRnMonad +import Name +import NameSet +import NameEnv +import DataCon +import SrcLoc +import Outputable +import Util +import BasicTypes ( TopLevelFlag(..) ) +import ListSetOps ( removeDups ) +import DynFlags +import FastString +import Control.Monad +import Data.List +import Constants ( mAX_TUPLE_SIZE ) +import qualified Data.List.NonEmpty as NE +import qualified GHC.LanguageExtensions as LangExt + +{- +********************************************************* +* * +\subsection{Binding} +* * +********************************************************* +-} + +newLocalBndrRn :: Located RdrName -> RnM Name +-- Used for non-top-level binders. These should +-- never be qualified. +newLocalBndrRn (L loc rdr_name) + | Just name <- isExact_maybe rdr_name + = return name -- This happens in code generated by Template Haskell + -- See Note [Binders in Template Haskell] in Convert.hs + | otherwise + = do { unless (isUnqual rdr_name) + (addErrAt loc (badQualBndrErr rdr_name)) + ; uniq <- newUnique + ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } + +newLocalBndrsRn :: [Located RdrName] -> RnM [Name] +newLocalBndrsRn = mapM newLocalBndrRn + +bindLocalNames :: [Name] -> RnM a -> RnM a +bindLocalNames names enclosed_scope + = do { lcl_env <- getLclEnv + ; let th_level = thLevel (tcl_th_ctxt lcl_env) + th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env) + [ (n, (NotTopLevel, th_level)) | n <- names ] + rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names + ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs' + , tcl_rdr = rdr_env' }) + enclosed_scope } + +bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) +bindLocalNamesFV names enclosed_scope + = do { (result, fvs) <- bindLocalNames names enclosed_scope + ; return (result, delFVs names fvs) } + +------------------------------------- + +extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) +extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside + +------------------------------------- +checkDupRdrNames :: [Located RdrName] -> RnM () +-- Check for duplicated names in a binding group +checkDupRdrNames rdr_names_w_loc + = mapM_ (dupNamesErr getLoc) dups + where + (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc + +checkDupNames :: [Name] -> RnM () +-- Check for duplicated names in a binding group +checkDupNames names = check_dup_names (filterOut isSystemName names) + -- See Note [Binders in Template Haskell] in Convert + +check_dup_names :: [Name] -> RnM () +check_dup_names names + = mapM_ (dupNamesErr nameSrcSpan) dups + where + (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names + +--------------------- +checkShadowedRdrNames :: [Located RdrName] -> RnM () +checkShadowedRdrNames loc_rdr_names + = do { envs <- getRdrEnvs + ; checkShadowedOccs envs get_loc_occ filtered_rdrs } + where + filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names + -- See Note [Binders in Template Haskell] in Convert + get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr) + +checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () +checkDupAndShadowedNames envs names + = do { check_dup_names filtered_names + ; checkShadowedOccs envs get_loc_occ filtered_names } + where + filtered_names = filterOut isSystemName names + -- See Note [Binders in Template Haskell] in Convert + get_loc_occ name = (nameSrcSpan name, nameOccName name) + +------------------------------------- +checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) + -> (a -> (SrcSpan, OccName)) + -> [a] -> RnM () +checkShadowedOccs (global_env,local_env) get_loc_occ ns + = whenWOptM Opt_WarnNameShadowing $ + do { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns)) + ; mapM_ check_shadow ns } + where + check_shadow n + | startsWithUnderscore occ = return () -- Do not report shadowing for "_x" + -- See #3262 + | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)] + | otherwise = do { gres' <- filterM is_shadowed_gre gres + ; complain (map pprNameProvenance gres') } + where + (loc,occ) = get_loc_occ n + mb_local = lookupLocalRdrOcc local_env occ + gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env + -- Make an Unqualified RdrName and look that up, so that + -- we don't find any GREs that are in scope qualified-only + + complain [] = return () + complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing) + loc + (shadowedNameWarn occ pp_locs) + + is_shadowed_gre :: GlobalRdrElt -> RnM Bool + -- Returns False for record selectors that are shadowed, when + -- punning or wild-cards are on (cf #2723) + is_shadowed_gre gre | isRecFldGRE gre + = do { dflags <- getDynFlags + ; return $ not (xopt LangExt.RecordPuns dflags + || xopt LangExt.RecordWildCards dflags) } + is_shadowed_gre _other = return True + + +{- +************************************************************************ +* * +\subsection{Free variable manipulation} +* * +************************************************************************ +-} + +-- A useful utility +addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars) +addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside + ; return (res, fvs1 `plusFV` fvs2) } + +mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) +mapFvRn f xs = do stuff <- mapM f xs + case unzip stuff of + (ys, fvs_s) -> return (ys, plusFVs fvs_s) + +mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars) +mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs) +mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) } + +{- +************************************************************************ +* * +\subsection{Envt utility functions} +* * +************************************************************************ +-} + +warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () +warnUnusedTopBinds gres + = whenWOptM Opt_WarnUnusedTopBinds + $ do env <- getGblEnv + let isBoot = tcg_src env == HsBootFile + let noParent gre = case gre_par gre of + NoParent -> True + _ -> False + -- Don't warn about unused bindings with parents in + -- .hs-boot files, as you are sometimes required to give + -- unused bindings (trac #3449). + -- HOWEVER, in a signature file, you are never obligated to put a + -- definition in the main text. Thus, if you define something + -- and forget to export it, we really DO want to warn. + gres' = if isBoot then filter noParent gres + else gres + warnUnusedGREs gres' + + +-- | Checks to see if we need to warn for -Wunused-record-wildcards or +-- -Wredundant-record-wildcards +checkUnusedRecordWildcard :: SrcSpan + -> FreeVars + -> Maybe [Name] + -> RnM () +checkUnusedRecordWildcard _ _ Nothing = return () +checkUnusedRecordWildcard loc _ (Just []) = do + -- Add a new warning if the .. pattern binds no variables + setSrcSpan loc $ warnRedundantRecordWildcard +checkUnusedRecordWildcard loc fvs (Just dotdot_names) = + setSrcSpan loc $ warnUnusedRecordWildcard dotdot_names fvs + + +-- | Produce a warning when the `..` pattern binds no new +-- variables. +-- +-- @ +-- data P = P { x :: Int } +-- +-- foo (P{x, ..}) = x +-- @ +-- +-- The `..` here doesn't bind any variables as `x` is already bound. +warnRedundantRecordWildcard :: RnM () +warnRedundantRecordWildcard = + whenWOptM Opt_WarnRedundantRecordWildcards + (addWarn (Reason Opt_WarnRedundantRecordWildcards) + redundantWildcardWarning) + + +-- | Produce a warning when no variables bound by a `..` pattern are used. +-- +-- @ +-- data P = P { x :: Int } +-- +-- foo (P{..}) = () +-- @ +-- +-- The `..` pattern binds `x` but it is not used in the RHS so we issue +-- a warning. +warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM () +warnUnusedRecordWildcard ns used_names = do + let used = filter (`elemNameSet` used_names) ns + traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used) + warnIfFlag Opt_WarnUnusedRecordWildcards (null used) + unusedRecordWildcardWarning + + + +warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns + :: [Name] -> FreeVars -> RnM () +warnUnusedLocalBinds = check_unused Opt_WarnUnusedLocalBinds +warnUnusedMatches = check_unused Opt_WarnUnusedMatches +warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns + +check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM () +check_unused flag bound_names used_names + = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names) + bound_names)) + +------------------------- +-- Helpers +warnUnusedGREs :: [GlobalRdrElt] -> RnM () +warnUnusedGREs gres = mapM_ warnUnusedGRE gres + +warnUnused :: WarningFlag -> [Name] -> RnM () +warnUnused flag names = do + fld_env <- mkFieldEnv <$> getGlobalRdrEnv + mapM_ (warnUnused1 flag fld_env) names + +warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM () +warnUnused1 flag fld_env name + = when (reportable name occ) $ + addUnusedWarning flag + occ (nameSrcSpan name) + (text $ "Defined but not used" ++ opt_str) + where + occ = case lookupNameEnv fld_env name of + Just (fl, _) -> mkVarOccFS fl + Nothing -> nameOccName name + opt_str = case flag of + Opt_WarnUnusedTypePatterns -> " on the right hand side" + _ -> "" + +warnUnusedGRE :: GlobalRdrElt -> RnM () +warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is }) + | lcl = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv + warnUnused1 Opt_WarnUnusedTopBinds fld_env name + | otherwise = when (reportable name occ) (mapM_ warn is) + where + occ = greOccName gre + warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg + where + span = importSpecLoc spec + pp_mod = quotes (ppr (importSpecModule spec)) + msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used") + +-- | Make a map from selector names to field labels and parent tycon +-- names, to be used when reporting unused record fields. +mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name) +mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre))) + | gres <- occEnvElts rdr_env + , gre <- gres + , Just lbl <- [greLabel gre] + ] + +-- | Should we report the fact that this 'Name' is unused? The +-- 'OccName' may differ from 'nameOccName' due to +-- DuplicateRecordFields. +reportable :: Name -> OccName -> Bool +reportable name occ + | isWiredInName name = False -- Don't report unused wired-in names + -- Otherwise we get a zillion warnings + -- from Data.Tuple + | otherwise = not (startsWithUnderscore occ) + +addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () +addUnusedWarning flag occ span msg + = addWarnAt (Reason flag) span $ + sep [msg <> colon, + nest 2 $ pprNonVarNameSpace (occNameSpace occ) + <+> quotes (ppr occ)] + +unusedRecordWildcardWarning :: SDoc +unusedRecordWildcardWarning = + wildcardDoc $ text "No variables bound in the record wildcard match are used" + +redundantWildcardWarning :: SDoc +redundantWildcardWarning = + wildcardDoc $ text "Record wildcard does not bind any new variables" + +wildcardDoc :: SDoc -> SDoc +wildcardDoc herald = + herald + $$ nest 2 (text "Possible fix" <> colon <+> text "omit the" + <+> quotes (text "..")) + +addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM () +addNameClashErrRn rdr_name gres + | all isLocalGRE gres && not (all isRecFldGRE gres) + -- If there are two or more *local* defns, we'll have reported + = return () -- that already, and we don't want an error cascade + | otherwise + = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name) + , text "It could refer to" + , nest 3 (vcat (msg1 : msgs)) ]) + where + (np1:nps) = gres + msg1 = text "either" <+> ppr_gre np1 + msgs = [text " or" <+> ppr_gre np | np <- nps] + ppr_gre gre = sep [ pp_gre_name gre <> comma + , pprNameProvenance gre] + + -- When printing the name, take care to qualify it in the same + -- way as the provenance reported by pprNameProvenance, namely + -- the head of 'gre_imp'. Otherwise we get confusing reports like + -- Ambiguous occurrence ‘null’ + -- It could refer to either ‘T15487a.null’, + -- imported from ‘Prelude’ at T15487.hs:1:8-13 + -- or ... + -- See #15487 + pp_gre_name gre@(GRE { gre_name = name, gre_par = parent + , gre_lcl = lcl, gre_imp = iss }) + | FldParent { par_lbl = Just lbl } <- parent + = text "the field" <+> quotes (ppr lbl) + | otherwise + = quotes (pp_qual <> dot <> ppr (nameOccName name)) + where + pp_qual | lcl + = ppr (nameModule name) + | imp : _ <- iss -- This 'imp' is the one that + -- pprNameProvenance chooses + , ImpDeclSpec { is_as = mod } <- is_decl imp + = ppr mod + | otherwise + = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss) + -- Invariant: either 'lcl' is True or 'iss' is non-empty + +shadowedNameWarn :: OccName -> [SDoc] -> SDoc +shadowedNameWarn occ shadowed_locs + = sep [text "This binding for" <+> quotes (ppr occ) + <+> text "shadows the existing binding" <> plural shadowed_locs, + nest 2 (vcat shadowed_locs)] + + +unknownSubordinateErr :: SDoc -> RdrName -> SDoc +unknownSubordinateErr doc op -- Doc is "method of class" or + -- "field of constructor" + = quotes (ppr op) <+> text "is not a (visible)" <+> doc + + +dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM () +dupNamesErr get_loc names + = addErrAt big_loc $ + vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)), + locations] + where + locs = map get_loc (NE.toList names) + big_loc = foldr1 combineSrcSpans locs + locations = text "Bound at:" <+> vcat (map ppr (sort locs)) + +badQualBndrErr :: RdrName -> SDoc +badQualBndrErr rdr_name + = text "Qualified name in binding position:" <+> ppr rdr_name + +typeAppErr :: String -> LHsType GhcPs -> SDoc +typeAppErr what (L _ k) + = hang (text "Illegal visible" <+> text what <+> text "application" + <+> quotes (char '@' <> ppr k)) + 2 (text "Perhaps you intended to use TypeApplications") + +checkTupSize :: Int -> RnM () +checkTupSize tup_size + | tup_size <= mAX_TUPLE_SIZE + = return () + | otherwise + = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"), + nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)), + nest 2 (text "Workaround: use nested tuples or define a data type")]) + + +{- +************************************************************************ +* * +\subsection{Contexts for renaming errors} +* * +************************************************************************ +-} + +-- AZ:TODO: Change these all to be Name instead of RdrName. +-- Merge TcType.UserTypeContext in to it. +data HsDocContext + = TypeSigCtx SDoc + | StandaloneKindSigCtx SDoc + | PatCtx + | SpecInstSigCtx + | DefaultDeclCtx + | ForeignDeclCtx (Located RdrName) + | DerivDeclCtx + | RuleCtx FastString + | TyDataCtx (Located RdrName) + | TySynCtx (Located RdrName) + | TyFamilyCtx (Located RdrName) + | FamPatCtx (Located RdrName) -- The patterns of a type/data family instance + | ConDeclCtx [Located Name] + | ClassDeclCtx (Located RdrName) + | ExprWithTySigCtx + | TypBrCtx + | HsTypeCtx + | GHCiCtx + | SpliceTypeCtx (LHsType GhcPs) + | ClassInstanceCtx + | GenericCtx SDoc -- Maybe we want to use this more! + +withHsDocContext :: HsDocContext -> SDoc -> SDoc +withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt + +inHsDocContext :: HsDocContext -> SDoc +inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt + +pprHsDocContext :: HsDocContext -> SDoc +pprHsDocContext (GenericCtx doc) = doc +pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc +pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc +pprHsDocContext PatCtx = text "a pattern type-signature" +pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma" +pprHsDocContext DefaultDeclCtx = text "a `default' declaration" +pprHsDocContext DerivDeclCtx = text "a deriving declaration" +pprHsDocContext (RuleCtx name) = text "the transformation rule" <+> ftext name +pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon) +pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon) +pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name) +pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name) +pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name) +pprHsDocContext ExprWithTySigCtx = text "an expression type signature" +pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type" +pprHsDocContext HsTypeCtx = text "a type argument" +pprHsDocContext GHCiCtx = text "GHCi input" +pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty) +pprHsDocContext ClassInstanceCtx = text "TcSplice.reifyInstances" + +pprHsDocContext (ForeignDeclCtx name) + = text "the foreign declaration for" <+> quotes (ppr name) +pprHsDocContext (ConDeclCtx [name]) + = text "the definition of data constructor" <+> quotes (ppr name) +pprHsDocContext (ConDeclCtx names) + = text "the definition of data constructors" <+> interpp'SP names diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 2a813344df..298bc6660a 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -1074,7 +1074,7 @@ the trees to reflect the fixities of the underlying operators: UInfixE x * (UInfixE y + z) ---> (x * y) + z This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and -@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely +@mkHsOpTyRn@ in GHC.Rename.Types), which expects that the input will be completely right-biased for types and left-biased for everything else. So we left-bias the trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@. @@ -1966,7 +1966,7 @@ usually want to print the name with the unique, and that is indeed the way System Names are printed. There's a small complication of course; see Note [Looking up Exact -RdrNames] in RnEnv. +RdrNames] in GHC.Rename.Env. -} {- |