summaryrefslogtreecommitdiff
path: root/compiler/rename/RnBinds.hs
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/rename/RnBinds.hs')
-rw-r--r--compiler/rename/RnBinds.hs1108
1 files changed, 1108 insertions, 0 deletions
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
new file mode 100644
index 0000000000..1af93f35d2
--- /dev/null
+++ b/compiler/rename/RnBinds.hs
@@ -0,0 +1,1108 @@
+{-
+(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).
+-}
+
+{-# LANGUAGE CPP #-}
+
+module RnBinds (
+ -- Renaming top-level bindings
+ rnTopBindsLHS, rnTopBindsRHS, rnValBindsRHS,
+
+ -- Renaming local bindings
+ rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
+
+ -- Other bindings
+ rnMethodBinds, renameSigs, mkSigTvFn,
+ rnMatchGroup, rnGRHSs, rnGRHS,
+ makeMiniFixityEnv, MiniFixityEnv,
+ HsSigCtxt(..)
+ ) where
+
+import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
+
+import HsSyn
+import TcRnMonad
+import TcEvidence ( emptyTcEvBinds )
+import RnTypes
+import RnPat
+import RnNames
+import RnEnv
+import DynFlags
+import Module
+import Name
+import NameEnv
+import NameSet
+import RdrName ( RdrName, rdrNameOcc )
+import SrcLoc
+import ListSetOps ( findDupsEq )
+import BasicTypes ( RecFlag(..) )
+import Digraph ( SCC(..) )
+import Bag
+import Outputable
+import FastString
+import Data.List ( partition, sort )
+import Maybes ( orElse )
+import Control.Monad
+#if __GLASGOW_HASKELL__ < 709
+import Data.Traversable ( traverse )
+#endif
+
+{-
+-- 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 RdrName
+ -> RnM (HsValBindsLR Name RdrName)
+rnTopBindsLHS fix_env binds
+ = rnValBindsLHS (topRecNameMaker fix_env) binds
+
+rnTopBindsRHS :: NameSet -> HsValBindsLR Name RdrName
+ -> RnM (HsValBinds Name, DefUses)
+rnTopBindsRHS bound_names binds
+ = do { is_boot <- tcIsHsBootOrSig
+ ; if is_boot
+ then rnTopBindsBoot binds
+ else rnValBindsRHS (TopSigCtxt bound_names False) binds }
+
+rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
+-- A hs-boot file has no bindings.
+-- Return a single HsBindGroup with empty binds and renamed signatures
+rnTopBindsBoot (ValBindsIn mbinds sigs)
+ = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
+ ; (sigs', fvs) <- renameSigs HsBootCtxt sigs
+ ; return (ValBindsOut [] sigs', usesOnly fvs) }
+rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b)
+
+{-
+*********************************************************
+* *
+ HsLocalBinds
+* *
+*********************************************************
+-}
+
+rnLocalBindsAndThen :: HsLocalBinds RdrName
+ -> (HsLocalBinds Name -> 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 thing_inside
+ = thing_inside EmptyLocalBinds
+
+rnLocalBindsAndThen (HsValBinds val_binds) thing_inside
+ = rnLocalValBindsAndThen val_binds $ \ val_binds' ->
+ thing_inside (HsValBinds val_binds')
+
+rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do
+ (binds',fv_binds) <- rnIPBinds binds
+ (thing, fvs_thing) <- thing_inside (HsIPBinds binds')
+ return (thing, fvs_thing `plusFV` fv_binds)
+
+rnIPBinds :: HsIPBinds RdrName -> RnM (HsIPBinds Name, FreeVars)
+rnIPBinds (IPBinds ip_binds _no_dict_binds) = do
+ (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
+ return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s)
+
+rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars)
+rnIPBind (IPBind ~(Left n) expr) = do
+ (expr',fvExpr) <- rnLExpr expr
+ return (IPBind (Left n) expr', fvExpr)
+
+{-
+************************************************************************
+* *
+ ValBinds
+* *
+************************************************************************
+-}
+
+-- Renaming local binding groups
+-- Does duplicate/shadow check
+rnLocalValBindsLHS :: MiniFixityEnv
+ -> HsValBinds RdrName
+ -> RnM ([Name], HsValBindsLR Name RdrName)
+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 HsUtils
+
+ -- 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'
+ ; 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 RdrName
+ -> RnM (HsValBindsLR Name RdrName)
+rnValBindsLHS topP (ValBindsIn mbinds sigs)
+ = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds
+ ; return $ ValBindsIn 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 Name RdrName
+ -> RnM (HsValBinds Name, DefUses)
+
+rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
+ = do { (sigs', sig_fvs) <- renameSigs ctxt sigs
+ ; binds_w_dus <- mapBagM (rnLBind (mkSigTvFn sigs')) mbinds
+ ; case depAnalBinds binds_w_dus of
+ (anal_binds, anal_dus) -> return (valbind', valbind'_dus)
+ where
+ valbind' = ValBindsOut anal_binds sigs'
+ valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs
+ -- Put the sig uses *after* the bindings
+ -- so that the binders are removed from
+ -- the uses in the sigs
+ }
+
+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 Name RdrName
+ -> RnM (HsValBinds Name, 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 RdrName
+ -> (HsValBinds Name -> RnM (result, FreeVars))
+ -> RnM (result, FreeVars)
+rnLocalValBindsAndThen binds@(ValBindsIn _ 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'
+
+ -- 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)
+ implicit_uses = hsValBindsImplicits binds'
+ ; 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)
+
+
+-- 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 RdrName] -> 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 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 [ptext (sLit "Multiple fixity declarations for") <+> quotes (ppr rdr_name),
+ ptext (sLit "also at ") <+> ppr loc]
+
+---------------------
+
+-- renaming a single bind
+
+rnBindLHS :: NameMaker
+ -> SDoc
+ -> HsBind RdrName
+ -- returns the renamed left-hand side,
+ -- and the FreeVars *of the LHS*
+ -- (i.e., any free variables of the pattern)
+ -> RnM (HsBindLR Name RdrName)
+
+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', bind_fvs = 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 = name@(L nameLoc _) })
+ = do { newname <- applyNameMaker name_maker name
+ ; return (bind { fun_id = L nameLoc newname
+ , bind_fvs = placeHolderNamesTc }) }
+
+rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname@(L nameLoc _) })
+ = do { unless (isTopRecNameMaker name_maker) $
+ addErr localPatternSynonymErr
+ ; addLocM checkConName rdrname
+ ; name <- applyNameMaker name_maker rdrname
+ ; return (PatSynBind psb{ psb_id = L nameLoc name }) }
+ where
+ localPatternSynonymErr :: SDoc
+ localPatternSynonymErr
+ = hang (ptext (sLit "Illegal pattern synonym declaration"))
+ 2 (ptext (sLit "Pattern synonym declarations are only valid in the top-level scope"))
+
+rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)
+
+rnLBind :: (Name -> [Name]) -- Signature tyvar function
+ -> LHsBindLR Name RdrName
+ -> RnM (LHsBind Name, [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 Name RdrName
+ -> RnM (HsBind Name, [Name], Uses)
+rnBind _ bind@(PatBind { pat_lhs = pat
+ , pat_rhs = grhss
+ -- pat fvs were stored in bind_fvs
+ -- after processing the LHS
+ , bind_fvs = 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_rhs_ty = placeHolderType, bind_fvs = fvs' }
+ is_wild_pat = case pat of
+ L _ (WildPat {}) -> True
+ L _ (BangPat (L _ (WildPat {}))) -> True -- #9127
+ _ -> False
+
+ -- Warn if the pattern binds no variables, except for the
+ -- entirely-explicit idiom _ = 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
+ ; whenWOptM Opt_WarnUnusedBinds $
+ when (null bndrs && not is_wild_pat) $
+ addWarn $ unusedPatBindWarn bind'
+
+ ; fvs' `seq` -- See Note [Free-variable space leak]
+ return (bind', bndrs, all_fvs) }
+
+rnBind sig_fn bind@(FunBind { fun_id = name
+ , fun_infix = is_infix
+ , 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 Opt_ScopedTyVars
+ rnMatchGroup (FunRhs plain_name is_infix)
+ rnLExpr matches
+ ; 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'
+ , bind_fvs = fvs' },
+ [plain_name], rhs_fvs)
+ }
+
+rnBind sig_fn (PatSynBind bind)
+ = do { (bind', name, fvs) <- rnPatSynBind sig_fn bind
+ ; return (PatSynBind bind', name, fvs) }
+
+rnBind _ b = pprPanic "rnBind" (ppr b)
+
+{-
+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.
+-}
+
+rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function
+ -> PatSynBind Name RdrName
+ -> RnM (PatSynBind Name Name, [Name], Uses)
+rnPatSynBind _sig_fn bind@(PSB { psb_id = 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 Opt_PatternSynonyms
+ ; unless pattern_synonym_ok (addErr patternSynonymErr)
+
+ ; ((pat', details'), fvs1) <- rnPat PatSyn pat $ \pat' -> do
+ -- We check the 'RdrName's instead of the 'Name's
+ -- so that the binding locations are reported
+ -- from the left-hand side
+ { (details', fvs) <- case details of
+ PrefixPatSyn vars ->
+ do { checkDupRdrNames vars
+ ; names <- mapM lookupVar vars
+ ; return (PrefixPatSyn names, mkFVs (map unLoc names)) }
+ InfixPatSyn var1 var2 ->
+ do { checkDupRdrNames [var1, var2]
+ ; name1 <- lookupVar var1
+ ; name2 <- lookupVar var2
+ -- ; checkPrecMatch -- TODO
+ ; return (InfixPatSyn name1 name2, mkFVs (map unLoc [name1, name2])) }
+ ; return ((pat', details'), fvs) }
+ ; (dir', fvs2) <- case dir of
+ Unidirectional -> return (Unidirectional, emptyFVs)
+ ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)
+ ExplicitBidirectional mg ->
+ do { (mg', fvs) <- rnMatchGroup PatSyn 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
+
+ ; let bind' = bind{ psb_args = details'
+ , psb_def = pat'
+ , psb_dir = dir'
+ , psb_fvs = fvs' }
+
+ ; fvs' `seq` -- See Note [Free-variable space leak]
+ return (bind', [name], fvs1)
+ -- See Note [Pattern synonym wrappers don't yield dependencies]
+ }
+ where
+ lookupVar = wrapLocM lookupOccRn
+
+ patternSynonymErr :: SDoc
+ patternSynonymErr
+ = hang (ptext (sLit "Illegal pattern synonym declaration"))
+ 2 (ptext (sLit "Use -XPatternSynonyms to enable this extension"))
+
+{-
+Note [Pattern synonym wrappers don't yield dependencies]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When renaming a pattern synonym that has an explicit wrapper,
+references in the wrapper 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 wrapper definition is not looked at.
+
+2. Typecheck the wrapper definition, which needs the typechecked
+definition of 'f' to be in scope.
+
+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).
+
+-}
+
+---------------------
+depAnalBinds :: Bag (LHsBind Name, [Name], Uses)
+ -> ([(RecFlag, LHsBinds Name)], DefUses)
+-- Dependency analysis; this is important so that
+-- unused-binding reporting is accurate
+depAnalBinds binds_w_dus
+ = (map get_binds sccs, map get_du sccs)
+ where
+ sccs = depAnal (\(_, defs, _) -> defs)
+ (\(_, _, uses) -> nameSetElems uses)
+ (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 :: 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 :: [a] -> [a]
+-- y :: [(a,a)] -> a
+-- (x,y) = e
+-- In e, 'a' will be in scope, and it'll be the one from 'y'!
+
+mkSigTvFn :: [LSig Name] -> (Name -> [Name])
+-- Return a lookup function that maps an Id Name to the names
+-- of the type variables that should scope over its body..
+mkSigTvFn sigs
+ = \n -> lookupNameEnv env n `orElse` []
+ where
+ extractScopedTyVars :: LHsType Name -> [Name]
+ extractScopedTyVars (L _ (HsForAllTy Explicit _ ltvs _ _)) = hsLKiTyVarNames ltvs
+ extractScopedTyVars _ = []
+
+ env :: NameEnv [Name]
+ env = mkNameEnv [ (name, nwcs ++ extractScopedTyVars ty) -- Kind variables and type variables
+ | L _ (TypeSig names ty nwcs) <- sigs
+ , L _ name <- names]
+ -- Note the pattern-match on "Explicit"; we only bind
+ -- type variables from signatures with an explicit top-level for-all
+
+{-
+@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 :: Name -- Class name
+ -> (Name -> [Name]) -- Signature tyvar function
+ -> LHsBinds RdrName
+ -> RnM (LHsBinds Name, FreeVars)
+
+rnMethodBinds cls sig_fn binds
+ = do { checkDupRdrNames meth_names
+ -- 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
+
+ ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) }
+ where
+ meth_names = collectMethodBinders binds
+ do_one (binds,fvs) bind
+ = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind
+ ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
+
+rnMethodBind :: Name
+ -> (Name -> [Name])
+ -> LHsBindLR RdrName RdrName
+ -> RnM (Bag (LHsBindLR Name Name), FreeVars)
+rnMethodBind cls sig_fn
+ (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix
+ , fun_matches = MG { mg_alts = matches
+ , mg_origin = origin } }))
+ = setSrcSpan loc $ do
+ sel_name <- wrapLocM (lookupInstDeclBndr cls (ptext (sLit "method"))) name
+ let plain_name = unLoc sel_name
+ -- We use the selector name as the binder
+
+ (new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
+ mapFvRn (rnMatch (FunRhs plain_name is_infix) rnLExpr)
+ matches
+ let new_group = mkMatchGroupName origin new_matches
+
+ when is_infix $ checkPrecMatch plain_name new_group
+ return (unitBag (L loc (bind { fun_id = sel_name
+ , fun_matches = new_group
+ , bind_fvs = fvs })),
+ fvs `addOneFV` plain_name)
+ -- The 'fvs' field isn't used for method binds
+
+-- Can't handle method pattern-bindings which bind multiple methods.
+rnMethodBind _ _ (L loc bind@(PatBind {})) = do
+ addErrAt loc (methodBindErr bind)
+ return (emptyBag, emptyFVs)
+
+-- Associated pattern synonyms are not implemented yet
+rnMethodBind _ _ (L loc bind@(PatSynBind {})) = do
+ addErrAt loc $ methodPatSynErr bind
+ return (emptyBag, emptyFVs)
+
+rnMethodBind _ _ b = pprPanic "rnMethodBind" (ppr b)
+
+{-
+************************************************************************
+* *
+\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 RdrName]
+ -> RnM ([LSig Name], 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 RdrName -> RnM (Sig Name, FreeVars)
+-- FixitySig is renamed elsewhere.
+renameSig _ (IdSig x)
+ = return (IdSig x, emptyFVs) -- Actually this never occurs
+
+renameSig ctxt sig@(TypeSig vs ty _)
+ = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
+ -- (named and anonymous) wildcards are bound here.
+ ; (wcs, ty') <- extractWildcards ty
+ ; bindLocatedLocalsFV wcs $ \wcs_new -> do {
+ (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty'
+ ; return (TypeSig new_vs new_ty wcs_new, fvs) } }
+
+renameSig ctxt sig@(GenericSig vs ty)
+ = do { defaultSigs_on <- xoptM Opt_DefaultSignatures
+ ; unless defaultSigs_on (addErr (defaultSigErr sig))
+ ; new_v <- mapM (lookupSigOccRn ctxt sig) vs
+ ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty
+ ; return (GenericSig new_v new_ty, fvs) }
+
+renameSig _ (SpecInstSig ty)
+ = do { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty
+ ; return (SpecInstSig 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) <- rnHsSigType (quotes (ppr v)) ty
+ ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys
+ ; return (SpecSig new_v new_ty inl, fvs) }
+ where
+ do_one (tys,fvs) ty
+ = do { (new_ty, fvs_ty) <- rnHsSigType (quotes (ppr v)) ty
+ ; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
+
+renameSig ctxt sig@(InlineSig v s)
+ = do { new_v <- lookupSigOccRn ctxt sig v
+ ; return (InlineSig new_v s, emptyFVs) }
+
+renameSig ctxt sig@(FixSig (FixitySig vs f))
+ = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
+ ; return (FixSig (FixitySig new_vs f), emptyFVs) }
+
+renameSig ctxt sig@(MinimalSig bf)
+ = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
+ return (MinimalSig new_bf, emptyFVs)
+
+renameSig ctxt sig@(PatSynSig v (flag, qtvs) prov req ty)
+ = do { v' <- lookupSigOccRn ctxt sig v
+ ; let doc = TypeSigCtx $ quotes (ppr v)
+ ; loc <- getSrcSpanM
+
+ ; let (tv_kvs, mentioned) = extractHsTysRdrTyVars (ty:unLoc prov ++ unLoc req)
+ ; tv_bndrs <- case flag of
+ Implicit ->
+ return $ mkHsQTvs . userHsTyVarBndrs loc $ mentioned
+ Explicit ->
+ do { let heading = ptext (sLit "In the pattern synonym type signature")
+ <+> quotes (ppr sig)
+ ; warnUnusedForAlls (heading $$ docOfHsDocContext doc) qtvs mentioned
+ ; return qtvs }
+ Qualified -> panic "renameSig: Qualified"
+
+ ; bindHsTyVars doc Nothing tv_kvs tv_bndrs $ \ tyvars -> do
+ { (prov', fvs1) <- rnContext doc prov
+ ; (req', fvs2) <- rnContext doc req
+ ; (ty', fvs3) <- rnLHsType doc ty
+
+ ; let fvs = plusFVs [fvs1, fvs2, fvs3]
+ ; return (PatSynSig v' (flag, tyvars) prov' req' ty', fvs) }}
+
+ppr_sig_bndrs :: [Located RdrName] -> SDoc
+ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
+
+okHsSig :: HsSigCtxt -> LSig a -> Bool
+okHsSig ctxt (L _ sig)
+ = case (sig, ctxt) of
+ (GenericSig {}, ClsDeclCtxt {}) -> True
+ (GenericSig {}, _) -> 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
+
+-------------------
+findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]]
+-- 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@(GenericSig ns _) = [(n,sig) | n <- ns]
+ 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 (GenericSig {}) (GenericSig {}) = True
+ mtch _ _ = False
+
+-- Warn about multiple MINIMAL signatures
+checkDupMinimalSigs :: [LSig RdrName] -> RnM ()
+checkDupMinimalSigs sigs
+ = case filter isMinimalLSig sigs of
+ minSigs@(_:_:_) -> dupMinimalSigErr minSigs
+ _ -> return ()
+
+{-
+************************************************************************
+* *
+\subsection{Match}
+* *
+************************************************************************
+-}
+
+rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name
+ -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
+ -> MatchGroup RdrName (Located (body RdrName))
+ -> RnM (MatchGroup Name (Located (body Name)), FreeVars)
+rnMatchGroup ctxt rnBody (MG { mg_alts = ms, mg_origin = origin })
+ = do { empty_case_ok <- xoptM Opt_EmptyCase
+ ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))
+ ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
+ ; return (mkMatchGroupName origin new_ms, ms_fvs) }
+
+rnMatch :: Outputable (body RdrName) => HsMatchContext Name
+ -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
+ -> LMatch RdrName (Located (body RdrName))
+ -> RnM (LMatch Name (Located (body Name)), FreeVars)
+rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody)
+
+rnMatch' :: Outputable (body RdrName) => HsMatchContext Name
+ -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
+ -> Match RdrName (Located (body RdrName))
+ -> RnM (Match Name (Located (body Name)), FreeVars)
+rnMatch' ctxt rnBody match@(Match pats maybe_rhs_sig grhss)
+ = do { -- Result type signatures are no longer supported
+ case maybe_rhs_sig of
+ Nothing -> return ()
+ Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty)
+
+ -- Now the main event
+ -- note that there are no local ficity decls for matches
+ ; rnPats ctxt pats $ \ pats' -> do
+ { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
+
+ ; return (Match pats' Nothing grhss', grhss_fvs) }}
+
+emptyCaseErr :: HsMatchContext Name -> SDoc
+emptyCaseErr ctxt = hang (ptext (sLit "Empty list of alternatives in") <+> pp_ctxt)
+ 2 (ptext (sLit "Use EmptyCase to allow this"))
+ where
+ pp_ctxt = case ctxt of
+ CaseAlt -> ptext (sLit "case expression")
+ LambdaExpr -> ptext (sLit "\\case expression")
+ _ -> ptext (sLit "(unexpected)") <+> pprMatchContextNoun ctxt
+
+
+resSigErr :: Outputable body
+ => HsMatchContext Name -> Match RdrName body -> HsType RdrName -> SDoc
+resSigErr ctxt match ty
+ = vcat [ ptext (sLit "Illegal result type signature") <+> quotes (ppr ty)
+ , nest 2 $ ptext (sLit
+ "Result signatures are no longer supported in pattern matches")
+ , pprMatchInCtxt ctxt match ]
+
+{-
+************************************************************************
+* *
+\subsubsection{Guarded right-hand sides (GRHSs)}
+* *
+************************************************************************
+-}
+
+rnGRHSs :: HsMatchContext Name
+ -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
+ -> GRHSs RdrName (Located (body RdrName))
+ -> RnM (GRHSs Name (Located (body Name)), FreeVars)
+rnGRHSs ctxt rnBody (GRHSs grhss binds)
+ = rnLocalBindsAndThen binds $ \ binds' -> do
+ (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss
+ return (GRHSs grhss' binds', fvGRHSs)
+
+rnGRHS :: HsMatchContext Name
+ -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
+ -> LGRHS RdrName (Located (body RdrName))
+ -> RnM (LGRHS Name (Located (body Name)), FreeVars)
+rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)
+
+rnGRHS' :: HsMatchContext Name
+ -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
+ -> GRHS RdrName (Located (body RdrName))
+ -> RnM (GRHS Name (Located (body Name)), FreeVars)
+rnGRHS' ctxt rnBody (GRHS guards rhs)
+ = do { pattern_guards_allowed <- xoptM Opt_PatternGuards
+ ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ ->
+ rnBody rhs
+
+ ; unless (pattern_guards_allowed || is_standard_guard guards')
+ (addWarn (nonStdGuardErr guards'))
+
+ ; return (GRHS 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
+
+{-
+************************************************************************
+* *
+\subsection{Error messages}
+* *
+************************************************************************
+-}
+
+dupSigDeclErr :: [(Located RdrName, Sig RdrName)] -> RnM ()
+dupSigDeclErr pairs@((L loc name, sig) : _)
+ = addErrAt loc $
+ vcat [ ptext (sLit "Duplicate") <+> what_it_is
+ <> ptext (sLit "s for") <+> quotes (ppr name)
+ , ptext (sLit "at") <+> vcat (map ppr $ sort $ map (getLoc . fst) pairs) ]
+ where
+ what_it_is = hsSigDoc sig
+
+dupSigDeclErr [] = panic "dupSigDeclErr"
+
+misplacedSigErr :: LSig Name -> RnM ()
+misplacedSigErr (L loc sig)
+ = addErrAt loc $
+ sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig]
+
+defaultSigErr :: Sig RdrName -> SDoc
+defaultSigErr sig = vcat [ hang (ptext (sLit "Unexpected default signature:"))
+ 2 (ppr sig)
+ , ptext (sLit "Use DefaultSignatures to enable default signatures") ]
+
+methodBindErr :: HsBindLR RdrName RdrName -> SDoc
+methodBindErr mbind
+ = hang (ptext (sLit "Pattern bindings (except simple variables) not allowed in instance declarations"))
+ 2 (ppr mbind)
+
+methodPatSynErr :: HsBindLR RdrName RdrName -> SDoc
+methodPatSynErr mbind
+ = hang (ptext (sLit "Pattern synonyms not allowed in class/instance declarations"))
+ 2 (ppr mbind)
+
+bindsInHsBootFile :: LHsBindsLR Name RdrName -> SDoc
+bindsInHsBootFile mbinds
+ = hang (ptext (sLit "Bindings in hs-boot files are not allowed"))
+ 2 (ppr mbinds)
+
+nonStdGuardErr :: Outputable body => [LStmtLR Name Name body] -> SDoc
+nonStdGuardErr guards
+ = hang (ptext (sLit "accepting non-standard pattern guards (use PatternGuards to suppress this message)"))
+ 4 (interpp'SP guards)
+
+unusedPatBindWarn :: HsBind Name -> SDoc
+unusedPatBindWarn bind
+ = hang (ptext (sLit "This pattern-binding binds no variables:"))
+ 2 (ppr bind)
+
+dupMinimalSigErr :: [LSig RdrName] -> RnM ()
+dupMinimalSigErr sigs@(L loc _ : _)
+ = addErrAt loc $
+ vcat [ ptext (sLit "Multiple minimal complete definitions")
+ , ptext (sLit "at") <+> vcat (map ppr $ sort $ map getLoc sigs)
+ , ptext (sLit "Combine alternative minimal complete definitions with `|'") ]
+dupMinimalSigErr [] = panic "dupMinimalSigErr"