diff options
Diffstat (limited to 'compiler/rename')
| -rw-r--r-- | compiler/rename/RnBinds.hs | 1334 | ||||
| -rw-r--r-- | compiler/rename/RnEnv.hs | 1702 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.hs | 2210 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.hs-boot | 17 | ||||
| -rw-r--r-- | compiler/rename/RnFixity.hs | 214 | ||||
| -rw-r--r-- | compiler/rename/RnHsDoc.hs | 25 | ||||
| -rw-r--r-- | compiler/rename/RnNames.hs | 1783 | ||||
| -rw-r--r-- | compiler/rename/RnPat.hs | 897 | ||||
| -rw-r--r-- | compiler/rename/RnSource.hs | 2415 | ||||
| -rw-r--r-- | compiler/rename/RnSplice.hs | 902 | ||||
| -rw-r--r-- | compiler/rename/RnSplice.hs-boot | 14 | ||||
| -rw-r--r-- | compiler/rename/RnTypes.hs | 1784 | ||||
| -rw-r--r-- | compiler/rename/RnUnbound.hs | 381 | ||||
| -rw-r--r-- | compiler/rename/RnUtils.hs | 514 | ||||
| -rw-r--r-- | compiler/rename/rename.tex | 18 |
15 files changed, 0 insertions, 14210 deletions
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs deleted file mode 100644 index 9b93af907b..0000000000 --- a/compiler/rename/RnBinds.hs +++ /dev/null @@ -1,1334 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} -{-# LANGUAGE TypeFamilies #-} - -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnBinds]{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 RnBinds ( - -- 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 #-} RnExpr( rnLExpr, rnStmts ) - -import GHC.Hs -import TcRnMonad -import RnTypes -import RnPat -import RnNames -import RnEnv -import RnFixity -import RnUtils ( 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/rename/RnEnv.hs b/compiler/rename/RnEnv.hs deleted file mode 100644 index 4ce5805785..0000000000 --- a/compiler/rename/RnEnv.hs +++ /dev/null @@ -1,1702 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-2006 - -RnEnv contains functions which convert RdrNames into Names. - --} - -{-# LANGUAGE CPP, MultiWayIf, NamedFieldPuns #-} - -module RnEnv ( - 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 RnUnbound -import RnUtils -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 RnNames - 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 RnEnv. - -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 RnBinds.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 RnEnv.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 - RnEnv.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 RnEnv.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 RnBinds -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/rename/RnExpr.hs b/compiler/rename/RnExpr.hs deleted file mode 100644 index 693d818f67..0000000000 --- a/compiler/rename/RnExpr.hs +++ /dev/null @@ -1,2210 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnExpr]{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 RnExpr ( - rnLExpr, rnExpr, rnStmts - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, - rnMatchGroup, rnGRHS, makeMiniFixityEnv) -import GHC.Hs -import TcEnv ( isBrackStage ) -import TcRnMonad -import Module ( getModule ) -import RnEnv -import RnFixity -import RnUtils ( HsDocContext(..), bindLocalNamesFV, checkDupNames - , bindLocalNames - , mapMaybeFvRn, mapFvRn - , warnUnusedLocalBinds, typeAppErr - , checkUnusedRecordWildcard ) -import RnUnbound ( reportUnboundName ) -import RnSplice ( rnBracket, rnSpliceExpr, checkThLocalName ) -import RnTypes -import RnPat -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/rename/RnExpr.hs-boot b/compiler/rename/RnExpr.hs-boot deleted file mode 100644 index 8a9c7818a1..0000000000 --- a/compiler/rename/RnExpr.hs-boot +++ /dev/null @@ -1,17 +0,0 @@ -module RnExpr 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/rename/RnFixity.hs b/compiler/rename/RnFixity.hs deleted file mode 100644 index aeff25094f..0000000000 --- a/compiler/rename/RnFixity.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -{- - -This module contains code which maintains and manipulates the -fixity environment during renaming. - --} -module RnFixity ( 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 RnUnbound - -{- -********************************************************* -* * - 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 RnNames.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/rename/RnHsDoc.hs b/compiler/rename/RnHsDoc.hs deleted file mode 100644 index 6af59a0210..0000000000 --- a/compiler/rename/RnHsDoc.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -module RnHsDoc ( 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/rename/RnNames.hs b/compiler/rename/RnNames.hs deleted file mode 100644 index 7cb2aeafbb..0000000000 --- a/compiler/rename/RnNames.hs +++ /dev/null @@ -1,1783 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnNames]{Extracting imported and top-level names in scope} --} - -{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - -module RnNames ( - 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 RnEnv -import RnFixity -import RnUtils ( 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 RnEnv - -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 RnEnv.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 RnEnv.hs. - | 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/rename/RnPat.hs b/compiler/rename/RnPat.hs deleted file mode 100644 index 59ab5446cd..0000000000 --- a/compiler/rename/RnPat.hs +++ /dev/null @@ -1,897 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnPat]{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 RnPat (-- 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 #-} RnExpr ( rnLExpr ) -import {-# SOURCE #-} RnSplice ( rnSplicePat ) - -#include "HsVersions.h" - -import GHC.Hs -import TcRnMonad -import TcHsSyn ( hsOverLitName ) -import RnEnv -import RnFixity -import RnUtils ( HsDocContext(..), newLocalBndrRn, bindLocalNames - , warnUnusedMatches, newLocalBndrRn - , checkUnusedRecordWildcard - , checkDupNames, checkDupAndShadowedNames - , checkTupSize , unknownSubordinateErr ) -import RnTypes -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 RnSource.hs). - -{- -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 RnSplice - 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/rename/RnSource.hs b/compiler/rename/RnSource.hs deleted file mode 100644 index a166a65bfb..0000000000 --- a/compiler/rename/RnSource.hs +++ /dev/null @@ -1,2415 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnSource]{Main pass of renamer} --} - -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module RnSource ( - rnSrcDecls, addTcgDUs, findSplice - ) where - -#include "HsVersions.h" - -import GhcPrelude - -import {-# SOURCE #-} RnExpr( rnLExpr ) -import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls ) - -import GHC.Hs -import FieldLabel -import RdrName -import RnTypes -import RnBinds -import RnEnv -import RnUtils ( HsDocContext(..), mapFvRn, bindLocalNames - , checkDupRdrNames, inHsDocContext, bindLocalNamesFV - , checkShadowedRdrNames, warnUnusedTypePatterns - , extendTyVarEnvFVRn, newLocalBndrsRn - , withHsDocContext ) -import RnUnbound ( mkUnboundName, notInScopeErr ) -import RnNames -import RnHsDoc ( 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 RnNames.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 RnNames.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 RnNames.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 RnNames.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/rename/RnSplice.hs b/compiler/rename/RnSplice.hs deleted file mode 100644 index 4094402697..0000000000 --- a/compiler/rename/RnSplice.hs +++ /dev/null @@ -1,902 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - -module RnSplice ( - 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 RnEnv -import RnUtils ( HsDocContext(..), newLocalBndrRn ) -import RnUnbound ( isUnboundName ) -import RnSource ( rnSrcDecls, findSplice ) -import RnPat ( rnPat ) -import BasicTypes ( TopLevelFlag, isTopLevel, SourceText(..) ) -import Outputable -import Module -import SrcLoc -import RnTypes ( rnLHsType ) - -import Control.Monad ( unless, when ) - -import {-# SOURCE #-} RnExpr ( 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 RnTypes.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 -RnPat, 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 RnPat, 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/rename/RnSplice.hs-boot b/compiler/rename/RnSplice.hs-boot deleted file mode 100644 index cd6021027e..0000000000 --- a/compiler/rename/RnSplice.hs-boot +++ /dev/null @@ -1,14 +0,0 @@ -module RnSplice 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/rename/RnTypes.hs b/compiler/rename/RnTypes.hs deleted file mode 100644 index 724dea866d..0000000000 --- a/compiler/rename/RnTypes.hs +++ /dev/null @@ -1,1784 +0,0 @@ -{- -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 - -\section[RnSource]{Main pass of renamer} --} - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} - -module RnTypes ( - -- 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 #-} RnSplice( rnSpliceType ) - -import DynFlags -import GHC.Hs -import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) -import RnEnv -import RnUtils ( HsDocContext(..), withHsDocContext, mapFvRn - , pprHsDocContext, bindLocalNamesFV, typeAppErr - , newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames ) -import RnFixity ( 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) RnSource, -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 -RnNames.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 RnSource --- 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 RnExpr.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/rename/RnUnbound.hs b/compiler/rename/RnUnbound.hs deleted file mode 100644 index 2de2fc1f0c..0000000000 --- a/compiler/rename/RnUnbound.hs +++ /dev/null @@ -1,381 +0,0 @@ -{- - -This module contains helper functions for reporting and creating -unbound variables. - --} -module RnUnbound ( 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/rename/RnUtils.hs b/compiler/rename/RnUtils.hs deleted file mode 100644 index 88996e31b1..0000000000 --- a/compiler/rename/RnUtils.hs +++ /dev/null @@ -1,514 +0,0 @@ -{- - -This module contains miscellaneous functions related to renaming. - --} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeFamilies #-} - -module RnUtils ( - checkDupRdrNames, checkShadowedRdrNames, - checkDupNames, checkDupAndShadowedNames, dupNamesErr, - checkTupSize, - addFvRn, mapFvRn, mapMaybeFvRn, - warnUnusedMatches, warnUnusedTypePatterns, - warnUnusedTopBinds, warnUnusedLocalBinds, - checkUnusedRecordWildcard, - mkFieldEnv, - unknownSubordinateErr, badQualBndrErr, typeAppErr, - HsDocContext(..), pprHsDocContext, - inHsDocContext, withHsDocContext, - - newLocalBndrRn, newLocalBndrsRn, - - bindLocalNames, bindLocalNamesFV, - - addNameClashErrRn, extendTyVarEnvFVRn - -) - -where - - -import GhcPrelude - -import GHC.Hs -import RdrName -import HscTypes -import TcEnv -import TcRnMonad -import Name -import NameSet -import NameEnv -import DataCon -import SrcLoc -import Outputable -import Util -import BasicTypes ( TopLevelFlag(..) ) -import ListSetOps ( removeDups ) -import DynFlags -import FastString -import Control.Monad -import Data.List -import Constants ( mAX_TUPLE_SIZE ) -import qualified Data.List.NonEmpty as NE -import qualified GHC.LanguageExtensions as LangExt - -{- -********************************************************* -* * -\subsection{Binding} -* * -********************************************************* --} - -newLocalBndrRn :: Located RdrName -> RnM Name --- Used for non-top-level binders. These should --- never be qualified. -newLocalBndrRn (L loc rdr_name) - | Just name <- isExact_maybe rdr_name - = return name -- This happens in code generated by Template Haskell - -- See Note [Binders in Template Haskell] in Convert.hs - | otherwise - = do { unless (isUnqual rdr_name) - (addErrAt loc (badQualBndrErr rdr_name)) - ; uniq <- newUnique - ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } - -newLocalBndrsRn :: [Located RdrName] -> RnM [Name] -newLocalBndrsRn = mapM newLocalBndrRn - -bindLocalNames :: [Name] -> RnM a -> RnM a -bindLocalNames names enclosed_scope - = do { lcl_env <- getLclEnv - ; let th_level = thLevel (tcl_th_ctxt lcl_env) - th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env) - [ (n, (NotTopLevel, th_level)) | n <- names ] - rdr_env' = extendLocalRdrEnvList (tcl_rdr lcl_env) names - ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs' - , tcl_rdr = rdr_env' }) - enclosed_scope } - -bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) -bindLocalNamesFV names enclosed_scope - = do { (result, fvs) <- bindLocalNames names enclosed_scope - ; return (result, delFVs names fvs) } - -------------------------------------- - -extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) -extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside - -------------------------------------- -checkDupRdrNames :: [Located RdrName] -> RnM () --- Check for duplicated names in a binding group -checkDupRdrNames rdr_names_w_loc - = mapM_ (dupNamesErr getLoc) dups - where - (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc - -checkDupNames :: [Name] -> RnM () --- Check for duplicated names in a binding group -checkDupNames names = check_dup_names (filterOut isSystemName names) - -- See Note [Binders in Template Haskell] in Convert - -check_dup_names :: [Name] -> RnM () -check_dup_names names - = mapM_ (dupNamesErr nameSrcSpan) dups - where - (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names - ---------------------- -checkShadowedRdrNames :: [Located RdrName] -> RnM () -checkShadowedRdrNames loc_rdr_names - = do { envs <- getRdrEnvs - ; checkShadowedOccs envs get_loc_occ filtered_rdrs } - where - filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names - -- See Note [Binders in Template Haskell] in Convert - get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr) - -checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () -checkDupAndShadowedNames envs names - = do { check_dup_names filtered_names - ; checkShadowedOccs envs get_loc_occ filtered_names } - where - filtered_names = filterOut isSystemName names - -- See Note [Binders in Template Haskell] in Convert - get_loc_occ name = (nameSrcSpan name, nameOccName name) - -------------------------------------- -checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) - -> (a -> (SrcSpan, OccName)) - -> [a] -> RnM () -checkShadowedOccs (global_env,local_env) get_loc_occ ns - = whenWOptM Opt_WarnNameShadowing $ - do { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns)) - ; mapM_ check_shadow ns } - where - check_shadow n - | startsWithUnderscore occ = return () -- Do not report shadowing for "_x" - -- See #3262 - | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)] - | otherwise = do { gres' <- filterM is_shadowed_gre gres - ; complain (map pprNameProvenance gres') } - where - (loc,occ) = get_loc_occ n - mb_local = lookupLocalRdrOcc local_env occ - gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env - -- Make an Unqualified RdrName and look that up, so that - -- we don't find any GREs that are in scope qualified-only - - complain [] = return () - complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing) - loc - (shadowedNameWarn occ pp_locs) - - is_shadowed_gre :: GlobalRdrElt -> RnM Bool - -- Returns False for record selectors that are shadowed, when - -- punning or wild-cards are on (cf #2723) - is_shadowed_gre gre | isRecFldGRE gre - = do { dflags <- getDynFlags - ; return $ not (xopt LangExt.RecordPuns dflags - || xopt LangExt.RecordWildCards dflags) } - is_shadowed_gre _other = return True - - -{- -************************************************************************ -* * -\subsection{Free variable manipulation} -* * -************************************************************************ --} - --- A useful utility -addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars) -addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside - ; return (res, fvs1 `plusFV` fvs2) } - -mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) -mapFvRn f xs = do stuff <- mapM f xs - case unzip stuff of - (ys, fvs_s) -> return (ys, plusFVs fvs_s) - -mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars) -mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs) -mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) } - -{- -************************************************************************ -* * -\subsection{Envt utility functions} -* * -************************************************************************ --} - -warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () -warnUnusedTopBinds gres - = whenWOptM Opt_WarnUnusedTopBinds - $ do env <- getGblEnv - let isBoot = tcg_src env == HsBootFile - let noParent gre = case gre_par gre of - NoParent -> True - _ -> False - -- Don't warn about unused bindings with parents in - -- .hs-boot files, as you are sometimes required to give - -- unused bindings (trac #3449). - -- HOWEVER, in a signature file, you are never obligated to put a - -- definition in the main text. Thus, if you define something - -- and forget to export it, we really DO want to warn. - gres' = if isBoot then filter noParent gres - else gres - warnUnusedGREs gres' - - --- | Checks to see if we need to warn for -Wunused-record-wildcards or --- -Wredundant-record-wildcards -checkUnusedRecordWildcard :: SrcSpan - -> FreeVars - -> Maybe [Name] - -> RnM () -checkUnusedRecordWildcard _ _ Nothing = return () -checkUnusedRecordWildcard loc _ (Just []) = do - -- Add a new warning if the .. pattern binds no variables - setSrcSpan loc $ warnRedundantRecordWildcard -checkUnusedRecordWildcard loc fvs (Just dotdot_names) = - setSrcSpan loc $ warnUnusedRecordWildcard dotdot_names fvs - - --- | Produce a warning when the `..` pattern binds no new --- variables. --- --- @ --- data P = P { x :: Int } --- --- foo (P{x, ..}) = x --- @ --- --- The `..` here doesn't bind any variables as `x` is already bound. -warnRedundantRecordWildcard :: RnM () -warnRedundantRecordWildcard = - whenWOptM Opt_WarnRedundantRecordWildcards - (addWarn (Reason Opt_WarnRedundantRecordWildcards) - redundantWildcardWarning) - - --- | Produce a warning when no variables bound by a `..` pattern are used. --- --- @ --- data P = P { x :: Int } --- --- foo (P{..}) = () --- @ --- --- The `..` pattern binds `x` but it is not used in the RHS so we issue --- a warning. -warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM () -warnUnusedRecordWildcard ns used_names = do - let used = filter (`elemNameSet` used_names) ns - traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used) - warnIfFlag Opt_WarnUnusedRecordWildcards (null used) - unusedRecordWildcardWarning - - - -warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns - :: [Name] -> FreeVars -> RnM () -warnUnusedLocalBinds = check_unused Opt_WarnUnusedLocalBinds -warnUnusedMatches = check_unused Opt_WarnUnusedMatches -warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns - -check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM () -check_unused flag bound_names used_names - = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names) - bound_names)) - -------------------------- --- Helpers -warnUnusedGREs :: [GlobalRdrElt] -> RnM () -warnUnusedGREs gres = mapM_ warnUnusedGRE gres - -warnUnused :: WarningFlag -> [Name] -> RnM () -warnUnused flag names = do - fld_env <- mkFieldEnv <$> getGlobalRdrEnv - mapM_ (warnUnused1 flag fld_env) names - -warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM () -warnUnused1 flag fld_env name - = when (reportable name occ) $ - addUnusedWarning flag - occ (nameSrcSpan name) - (text $ "Defined but not used" ++ opt_str) - where - occ = case lookupNameEnv fld_env name of - Just (fl, _) -> mkVarOccFS fl - Nothing -> nameOccName name - opt_str = case flag of - Opt_WarnUnusedTypePatterns -> " on the right hand side" - _ -> "" - -warnUnusedGRE :: GlobalRdrElt -> RnM () -warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is }) - | lcl = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv - warnUnused1 Opt_WarnUnusedTopBinds fld_env name - | otherwise = when (reportable name occ) (mapM_ warn is) - where - occ = greOccName gre - warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg - where - span = importSpecLoc spec - pp_mod = quotes (ppr (importSpecModule spec)) - msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used") - --- | Make a map from selector names to field labels and parent tycon --- names, to be used when reporting unused record fields. -mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name) -mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre))) - | gres <- occEnvElts rdr_env - , gre <- gres - , Just lbl <- [greLabel gre] - ] - --- | Should we report the fact that this 'Name' is unused? The --- 'OccName' may differ from 'nameOccName' due to --- DuplicateRecordFields. -reportable :: Name -> OccName -> Bool -reportable name occ - | isWiredInName name = False -- Don't report unused wired-in names - -- Otherwise we get a zillion warnings - -- from Data.Tuple - | otherwise = not (startsWithUnderscore occ) - -addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () -addUnusedWarning flag occ span msg - = addWarnAt (Reason flag) span $ - sep [msg <> colon, - nest 2 $ pprNonVarNameSpace (occNameSpace occ) - <+> quotes (ppr occ)] - -unusedRecordWildcardWarning :: SDoc -unusedRecordWildcardWarning = - wildcardDoc $ text "No variables bound in the record wildcard match are used" - -redundantWildcardWarning :: SDoc -redundantWildcardWarning = - wildcardDoc $ text "Record wildcard does not bind any new variables" - -wildcardDoc :: SDoc -> SDoc -wildcardDoc herald = - herald - $$ nest 2 (text "Possible fix" <> colon <+> text "omit the" - <+> quotes (text "..")) - -addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM () -addNameClashErrRn rdr_name gres - | all isLocalGRE gres && not (all isRecFldGRE gres) - -- If there are two or more *local* defns, we'll have reported - = return () -- that already, and we don't want an error cascade - | otherwise - = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name) - , text "It could refer to" - , nest 3 (vcat (msg1 : msgs)) ]) - where - (np1:nps) = gres - msg1 = text "either" <+> ppr_gre np1 - msgs = [text " or" <+> ppr_gre np | np <- nps] - ppr_gre gre = sep [ pp_gre_name gre <> comma - , pprNameProvenance gre] - - -- When printing the name, take care to qualify it in the same - -- way as the provenance reported by pprNameProvenance, namely - -- the head of 'gre_imp'. Otherwise we get confusing reports like - -- Ambiguous occurrence ‘null’ - -- It could refer to either ‘T15487a.null’, - -- imported from ‘Prelude’ at T15487.hs:1:8-13 - -- or ... - -- See #15487 - pp_gre_name gre@(GRE { gre_name = name, gre_par = parent - , gre_lcl = lcl, gre_imp = iss }) - | FldParent { par_lbl = Just lbl } <- parent - = text "the field" <+> quotes (ppr lbl) - | otherwise - = quotes (pp_qual <> dot <> ppr (nameOccName name)) - where - pp_qual | lcl - = ppr (nameModule name) - | imp : _ <- iss -- This 'imp' is the one that - -- pprNameProvenance chooses - , ImpDeclSpec { is_as = mod } <- is_decl imp - = ppr mod - | otherwise - = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss) - -- Invariant: either 'lcl' is True or 'iss' is non-empty - -shadowedNameWarn :: OccName -> [SDoc] -> SDoc -shadowedNameWarn occ shadowed_locs - = sep [text "This binding for" <+> quotes (ppr occ) - <+> text "shadows the existing binding" <> plural shadowed_locs, - nest 2 (vcat shadowed_locs)] - - -unknownSubordinateErr :: SDoc -> RdrName -> SDoc -unknownSubordinateErr doc op -- Doc is "method of class" or - -- "field of constructor" - = quotes (ppr op) <+> text "is not a (visible)" <+> doc - - -dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM () -dupNamesErr get_loc names - = addErrAt big_loc $ - vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)), - locations] - where - locs = map get_loc (NE.toList names) - big_loc = foldr1 combineSrcSpans locs - locations = text "Bound at:" <+> vcat (map ppr (sort locs)) - -badQualBndrErr :: RdrName -> SDoc -badQualBndrErr rdr_name - = text "Qualified name in binding position:" <+> ppr rdr_name - -typeAppErr :: String -> LHsType GhcPs -> SDoc -typeAppErr what (L _ k) - = hang (text "Illegal visible" <+> text what <+> text "application" - <+> quotes (char '@' <> ppr k)) - 2 (text "Perhaps you intended to use TypeApplications") - -checkTupSize :: Int -> RnM () -checkTupSize tup_size - | tup_size <= mAX_TUPLE_SIZE - = return () - | otherwise - = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"), - nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)), - nest 2 (text "Workaround: use nested tuples or define a data type")]) - - -{- -************************************************************************ -* * -\subsection{Contexts for renaming errors} -* * -************************************************************************ --} - --- AZ:TODO: Change these all to be Name instead of RdrName. --- Merge TcType.UserTypeContext in to it. -data HsDocContext - = TypeSigCtx SDoc - | StandaloneKindSigCtx SDoc - | PatCtx - | SpecInstSigCtx - | DefaultDeclCtx - | ForeignDeclCtx (Located RdrName) - | DerivDeclCtx - | RuleCtx FastString - | TyDataCtx (Located RdrName) - | TySynCtx (Located RdrName) - | TyFamilyCtx (Located RdrName) - | FamPatCtx (Located RdrName) -- The patterns of a type/data family instance - | ConDeclCtx [Located Name] - | ClassDeclCtx (Located RdrName) - | ExprWithTySigCtx - | TypBrCtx - | HsTypeCtx - | GHCiCtx - | SpliceTypeCtx (LHsType GhcPs) - | ClassInstanceCtx - | GenericCtx SDoc -- Maybe we want to use this more! - -withHsDocContext :: HsDocContext -> SDoc -> SDoc -withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt - -inHsDocContext :: HsDocContext -> SDoc -inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt - -pprHsDocContext :: HsDocContext -> SDoc -pprHsDocContext (GenericCtx doc) = doc -pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc -pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc -pprHsDocContext PatCtx = text "a pattern type-signature" -pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma" -pprHsDocContext DefaultDeclCtx = text "a `default' declaration" -pprHsDocContext DerivDeclCtx = text "a deriving declaration" -pprHsDocContext (RuleCtx name) = text "the transformation rule" <+> ftext name -pprHsDocContext (TyDataCtx tycon) = text "the data type declaration for" <+> quotes (ppr tycon) -pprHsDocContext (FamPatCtx tycon) = text "a type pattern of family instance for" <+> quotes (ppr tycon) -pprHsDocContext (TySynCtx name) = text "the declaration for type synonym" <+> quotes (ppr name) -pprHsDocContext (TyFamilyCtx name) = text "the declaration for type family" <+> quotes (ppr name) -pprHsDocContext (ClassDeclCtx name) = text "the declaration for class" <+> quotes (ppr name) -pprHsDocContext ExprWithTySigCtx = text "an expression type signature" -pprHsDocContext TypBrCtx = text "a Template-Haskell quoted type" -pprHsDocContext HsTypeCtx = text "a type argument" -pprHsDocContext GHCiCtx = text "GHCi input" -pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty) -pprHsDocContext ClassInstanceCtx = text "TcSplice.reifyInstances" - -pprHsDocContext (ForeignDeclCtx name) - = text "the foreign declaration for" <+> quotes (ppr name) -pprHsDocContext (ConDeclCtx [name]) - = text "the definition of data constructor" <+> quotes (ppr name) -pprHsDocContext (ConDeclCtx names) - = text "the definition of data constructors" <+> interpp'SP names diff --git a/compiler/rename/rename.tex b/compiler/rename/rename.tex deleted file mode 100644 index b3f8e1d770..0000000000 --- a/compiler/rename/rename.tex +++ /dev/null @@ -1,18 +0,0 @@ -\documentstyle{report} -\input{lit-style} - -\begin{document} -\centerline{{\Large{rename}}} -\tableofcontents - -\input{Rename} % {Renaming and dependency analysis passes} -\input{RnSource} % {Main pass of renamer} -\input{RnMonad} % {The monad used by the renamer} -\input{RnEnv} % {Environment manipulation for the renamer monad} -\input{RnHsSyn} % {Specialisations of the @HsSyn@ syntax for the renamer} -\input{RnNames} % {Extracting imported and top-level names in scope} -\input{RnExpr} % {Renaming of expressions} -\input{RnBinds} % {Renaming and dependency analysis of bindings} -\input{RnIfaces} % {Cacheing and Renaming of Interfaces} - -\end{document} |