diff options
Diffstat (limited to 'compiler/GHC/Rename')
| -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 |
14 files changed, 14199 insertions, 0 deletions
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 |