diff options
Diffstat (limited to 'compiler/rename')
| -rw-r--r-- | compiler/rename/RnBinds.lhs | 660 | ||||
| -rw-r--r-- | compiler/rename/RnEnv.lhs | 811 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.hi-boot-6 | 11 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.lhs | 996 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.lhs-boot | 17 | ||||
| -rw-r--r-- | compiler/rename/RnHsSyn.lhs | 156 | ||||
| -rw-r--r-- | compiler/rename/RnNames.lhs | 1138 | ||||
| -rw-r--r-- | compiler/rename/RnSource.hi-boot-5 | 13 | ||||
| -rw-r--r-- | compiler/rename/RnSource.lhs | 722 | ||||
| -rw-r--r-- | compiler/rename/RnTypes.lhs | 766 | ||||
| -rw-r--r-- | compiler/rename/rename.tex | 18 |
11 files changed, 5308 insertions, 0 deletions
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs new file mode 100644 index 0000000000..13035e72e2 --- /dev/null +++ b/compiler/rename/RnBinds.lhs @@ -0,0 +1,660 @@ +% +% (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). + +\begin{code} +module RnBinds ( + rnTopBinds, + rnLocalBindsAndThen, rnValBindsAndThen, rnValBinds, trimWith, + rnMethodBinds, renameSigs, + rnMatchGroup, rnGRHSs + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) + +import HsSyn +import RdrHsSyn +import RnHsSyn +import TcRnMonad +import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs, + rnLPat, rnPatsAndThen, patSigErr, checkPrecMatch ) +import RnEnv ( bindLocatedLocalsRn, lookupLocatedBndrRn, + lookupLocatedInstDeclBndr, newIPNameRn, + lookupLocatedSigOccRn, bindPatSigTyVars, bindPatSigTyVarsFV, + bindLocalFixities, bindSigTyVarsFV, + warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, + ) +import DynFlags ( DynFlag(..) ) +import Name ( Name, nameOccName, nameSrcLoc ) +import NameEnv +import NameSet +import PrelNames ( isUnboundName ) +import RdrName ( RdrName, rdrNameOcc ) +import SrcLoc ( mkSrcSpan, Located(..), unLoc ) +import ListSetOps ( findDupsEq ) +import BasicTypes ( RecFlag(..) ) +import Digraph ( SCC(..), stronglyConnComp ) +import Bag +import Outputable +import Maybes ( orElse, isJust ) +import Util ( filterOut ) +import Monad ( foldM ) +\end{code} + +-- 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} +%* * +%************************************************************************ + +@rnTopMonoBinds@ assumes that the environment already +contains bindings for the binders of this particular binding. + +\begin{code} +rnTopBinds :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) + +-- The binders of the binding are in scope already; +-- the top level scope resolution does that + +rnTopBinds binds + = do { is_boot <- tcIsHsBoot + ; if is_boot then rnTopBindsBoot binds + else rnTopBindsSrc binds } + +rnTopBindsBoot :: HsValBinds 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' <- renameSigs okHsBootSig sigs + ; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) } + +rnTopBindsSrc :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) +rnTopBindsSrc binds@(ValBindsIn mbinds _) + = do { (binds', dus) <- rnValBinds noTrim binds + + -- Warn about missing signatures, + ; let { ValBindsOut _ sigs' = binds' + ; ty_sig_vars = mkNameSet [ unLoc n | L _ (TypeSig n _) <- sigs'] + ; un_sigd_bndrs = duDefs dus `minusNameSet` ty_sig_vars } + + ; warn_missing_sigs <- doptM Opt_WarnMissingSigs + ; ifM (warn_missing_sigs) + (mappM_ missingSigWarn (nameSetToList un_sigd_bndrs)) + + ; return (binds', dus) + } +\end{code} + + + +%********************************************************* +%* * + HsLocalBinds +%* * +%********************************************************* + +\begin{code} +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 + = rnValBindsAndThen val_binds $ \ val_binds' -> + thing_inside (HsValBinds val_binds') + +rnLocalBindsAndThen (HsIPBinds binds) thing_inside + = rnIPBinds binds `thenM` \ (binds',fv_binds) -> + thing_inside (HsIPBinds binds') `thenM` \ (thing, fvs_thing) -> + returnM (thing, fvs_thing `plusFV` fv_binds) + +------------- +rnIPBinds (IPBinds ip_binds _no_dict_binds) + = do { (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds + ; return (IPBinds ip_binds' emptyLHsBinds, plusFVs fvs_s) } + +rnIPBind (IPBind n expr) + = newIPNameRn n `thenM` \ name -> + rnLExpr expr `thenM` \ (expr',fvExpr) -> + return (IPBind name expr', fvExpr) +\end{code} + + +%************************************************************************ +%* * + ValBinds +%* * +%************************************************************************ + +\begin{code} +rnValBindsAndThen :: HsValBinds RdrName + -> (HsValBinds Name -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) + +rnValBindsAndThen binds@(ValBindsIn mbinds sigs) thing_inside + = -- Extract all the binders in this group, and extend the + -- current scope, inventing new names for the new binders + -- This also checks that the names form a set + bindLocatedLocalsRn doc mbinders_w_srclocs $ \ bndrs -> + + -- Then install local fixity declarations + -- Notice that they scope over thing_inside too + bindLocalFixities [sig | L _ (FixSig sig) <- sigs ] $ + + -- Do the business + rnValBinds (trimWith bndrs) binds `thenM` \ (binds, bind_dus) -> + + -- Now do the "thing inside" + thing_inside binds `thenM` \ (result,result_fvs) -> + + -- Final error checking + let + all_uses = duUses bind_dus `plusFV` result_fvs + -- duUses: It's important to return all the uses, not the 'real uses' + -- used for warning about unused bindings. 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 + + unused_bndrs = [ b | b <- bndrs, not (b `elemNameSet` all_uses)] + in + warnUnusedLocalBinds unused_bndrs `thenM_` + + returnM (result, delListFromNameSet all_uses bndrs) + where + mbinders_w_srclocs = collectHsBindLocatedBinders mbinds + doc = text "In the binding group for:" + <+> pprWithCommas ppr (map unLoc mbinders_w_srclocs) + +--------------------- +rnValBinds :: (FreeVars -> FreeVars) + -> HsValBinds RdrName + -> RnM (HsValBinds Name, DefUses) +-- Assumes the binders of the binding are in scope already + +rnValBinds trim (ValBindsIn mbinds sigs) + = do { sigs' <- rename_sigs sigs + + ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds + + ; let (binds', bind_dus) = depAnalBinds binds_w_dus + + -- We do the check-sigs after renaming the bindings, + -- so that we have convenient access to the binders + ; check_sigs (okBindSig (duDefs bind_dus)) sigs' + + ; return (ValBindsOut binds' sigs', + usesOnly (hsSigsFVs sigs') `plusDU` bind_dus) } + + +--------------------- +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 = stronglyConnComp edges + + keyd_nodes = bagToList binds_w_dus `zip` [0::Int ..] + + edges = [ (node, key, [key | n <- nameSetToList uses, + Just key <- [lookupNameEnv key_map n] ]) + | (node@(_,_,uses), key) <- keyd_nodes ] + + key_map :: NameEnv Int -- Which binding it comes from + key_map = mkNameEnv [(bndr, key) | ((_, bndrs, _), key) <- keyd_nodes + , bndr <- bndrs ] + + get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind) + get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,d,u) <- 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 = unionManyNameSets [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 + env :: NameEnv [Name] + env = mkNameEnv [ (name, map hsLTyVarName ltvs) + | L _ (TypeSig (L _ name) + (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs] + -- Note the pattern-match on "Explicit"; we only bind + -- type variables from signatures with an explicit top-level for-all + +-- The trimming function trims the free vars we attach to a +-- binding so that it stays reasonably small +noTrim :: FreeVars -> FreeVars +noTrim fvs = fvs -- Used at top level + +trimWith :: [Name] -> FreeVars -> FreeVars +-- Nested bindings; trim by intersection with the names bound here +trimWith bndrs = intersectNameSet (mkNameSet bndrs) + +--------------------- +rnBind :: (Name -> [Name]) -- Signature tyvar function + -> (FreeVars -> FreeVars) -- Trimming function for rhs free vars + -> LHsBind RdrName + -> RnM (LHsBind Name, [Name], Uses) +rnBind sig_fn trim (L loc (PatBind { pat_lhs = pat, pat_rhs = grhss })) + = setSrcSpan loc $ + do { (pat', pat_fvs) <- rnLPat pat + + ; let bndrs = collectPatBinders pat' + + ; (grhss', fvs) <- bindSigTyVarsFV (concatMap sig_fn bndrs) $ + rnGRHSs PatBindRhs grhss + + ; return (L loc (PatBind { pat_lhs = pat', pat_rhs = grhss', + pat_rhs_ty = placeHolderType, bind_fvs = trim fvs }), + bndrs, pat_fvs `plusFV` fvs) } + +rnBind sig_fn trim (L loc (FunBind { fun_id = name, fun_infix = inf, fun_matches = matches })) + = setSrcSpan loc $ + do { new_name <- lookupLocatedBndrRn name + ; let plain_name = unLoc new_name + + ; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ + rnMatchGroup (FunRhs plain_name) matches + + ; checkPrecMatch inf plain_name matches' + + ; return (L loc (FunBind { fun_id = new_name, fun_infix = inf, fun_matches = matches', + bind_fvs = trim fvs, fun_co_fn = idCoercion }), + [plain_name], fvs) + } +\end{code} + + +@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. + +\begin{code} +rnMethodBinds :: Name -- Class name + -> [Name] -- Names for generic type variables + -> LHsBinds RdrName + -> RnM (LHsBinds Name, FreeVars) + +rnMethodBinds cls gen_tyvars binds + = foldM do_one (emptyBag,emptyFVs) (bagToList binds) + where do_one (binds,fvs) bind = do + (bind', fvs_bind) <- rnMethodBind cls gen_tyvars bind + return (bind' `unionBags` binds, fvs_bind `plusFV` fvs) + +rnMethodBind cls gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = inf, + fun_matches = MatchGroup matches _ })) + = setSrcSpan loc $ + lookupLocatedInstDeclBndr cls name `thenM` \ sel_name -> + let plain_name = unLoc sel_name in + -- We use the selector name as the binder + + mapFvRn (rn_match plain_name) matches `thenM` \ (new_matches, fvs) -> + let + new_group = MatchGroup new_matches placeHolderType + in + checkPrecMatch inf plain_name new_group `thenM_` + returnM (unitBag (L loc (FunBind { fun_id = sel_name, fun_infix = inf, fun_matches = new_group, + bind_fvs = fvs, fun_co_fn = idCoercion })), + fvs `addOneFV` plain_name) + -- The 'fvs' field isn't used for method binds + where + -- Truly gruesome; bring into scope the correct members of the generic + -- type variables. See comments in RnSource.rnSourceDecl(ClassDecl) + rn_match sel_name match@(L _ (Match (L _ (TypePat ty) : _) _ _)) + = extendTyVarEnvFVRn gen_tvs $ + rnMatch (FunRhs sel_name) match + where + tvs = map (rdrNameOcc.unLoc) (extractHsTyRdrTyVars ty) + gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs] + + rn_match sel_name match = rnMatch (FunRhs sel_name) match + + +-- Can't handle method pattern-bindings which bind multiple methods. +rnMethodBind cls gen_tyvars mbind@(L loc (PatBind other_pat _ _ _)) + = addLocErr mbind methodBindErr `thenM_` + returnM (emptyBag, emptyFVs) +\end{code} + + +%************************************************************************ +%* * +\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; +\item with suitably flaggery, that all top-level things have type signatures. +\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. + +\begin{code} +renameSigs :: (LSig Name -> Bool) -> [LSig RdrName] -> RnM [LSig Name] +-- Renames the signatures and performs error checks +renameSigs ok_sig sigs + = do { sigs' <- rename_sigs sigs + ; check_sigs ok_sig sigs' + ; return sigs' } + +---------------------- +rename_sigs :: [LSig RdrName] -> RnM [LSig Name] +rename_sigs sigs = mappM (wrapLocM renameSig) + (filter (not . isFixityLSig) sigs) + -- Remove fixity sigs which have been dealt with already + +---------------------- +check_sigs :: (LSig Name -> Bool) -> [LSig Name] -> RnM () +-- Used for class and instance decls, as well as regular bindings +check_sigs ok_sig sigs + -- Check for (a) duplicate signatures + -- (b) signatures for things not in this group + = do { mappM_ unknownSigErr (filter (not . ok_sig) sigs') + ; mappM_ dupSigDeclErr (findDupsEq eqHsSig sigs') } + where + -- Don't complain about an unbound name again + sigs' = filterOut bad_name sigs + bad_name sig = case sigName sig of + Just n -> isUnboundName n + other -> False + +-- We use lookupLocatedSigOccRn 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 :: Sig RdrName -> RnM (Sig Name) +-- FixitSig is renamed elsewhere. +renameSig (TypeSig v ty) + = lookupLocatedSigOccRn v `thenM` \ new_v -> + rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty -> + returnM (TypeSig new_v new_ty) + +renameSig (SpecInstSig ty) + = rnLHsType (text "A SPECIALISE instance pragma") ty `thenM` \ new_ty -> + returnM (SpecInstSig new_ty) + +renameSig (SpecSig v ty inl) + = lookupLocatedSigOccRn v `thenM` \ new_v -> + rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty -> + returnM (SpecSig new_v new_ty inl) + +renameSig (InlineSig v s) + = lookupLocatedSigOccRn v `thenM` \ new_v -> + returnM (InlineSig new_v s) +\end{code} + + +************************************************************************ +* * +\subsection{Match} +* * +************************************************************************ + +\begin{code} +rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars) +rnMatchGroup ctxt (MatchGroup ms _) + = mapFvRn (rnMatch ctxt) ms `thenM` \ (new_ms, ms_fvs) -> + returnM (MatchGroup new_ms placeHolderType, ms_fvs) + +rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars) +rnMatch ctxt = wrapLocFstM (rnMatch' ctxt) + +rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) + = + -- Deal with the rhs type signature + bindPatSigTyVarsFV rhs_sig_tys $ + doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> + (case maybe_rhs_sig of + Nothing -> returnM (Nothing, emptyFVs) + Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) -> + returnM (Just ty', ty_fvs) + | otherwise -> addLocErr ty patSigErr `thenM_` + returnM (Nothing, emptyFVs) + ) `thenM` \ (maybe_rhs_sig', ty_fvs) -> + + -- Now the main event + rnPatsAndThen ctxt pats $ \ pats' -> + rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) -> + + returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs) + -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs + where + rhs_sig_tys = case maybe_rhs_sig of + Nothing -> [] + Just ty -> [ty] + doc_sig = text "In a result type-signature" +\end{code} + + +%************************************************************************ +%* * +\subsubsection{Guarded right-hand sides (GRHSs)} +%* * +%************************************************************************ + +\begin{code} +rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars) + +rnGRHSs ctxt (GRHSs grhss binds) + = rnLocalBindsAndThen binds $ \ binds' -> + mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) -> + returnM (GRHSs grhss' binds', fvGRHSs) + +rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars) +rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt) + +rnGRHS' ctxt (GRHS guards rhs) + = do { opt_GlasgowExts <- doptM Opt_GlasgowExts + ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ + rnLExpr rhs + + ; checkM (opt_GlasgowExts || 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 _ (ExprStmt _ _ _)] = True + is_standard_guard other = False +\end{code} + +%************************************************************************ +%* * +\subsection{Error messages} +%* * +%************************************************************************ + +\begin{code} +dupSigDeclErr sigs@(L loc sig : _) + = addErrAt loc $ + vcat [ptext SLIT("Duplicate") <+> what_it_is <> colon, + nest 2 (vcat (map ppr_sig sigs))] + where + what_it_is = hsSigDoc sig + ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig + +unknownSigErr (L loc sig) + = addErrAt loc $ + sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, ppr sig] + where + what_it_is = hsSigDoc sig + +missingSigWarn var + = addWarnAt (mkSrcSpan loc loc) $ + sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)] + where + loc = nameSrcLoc var -- TODO: make a proper span + +methodBindErr mbind + = hang (ptext SLIT("Pattern bindings (except simple variables) not allowed in instance declarations")) + 2 (ppr mbind) + +bindsInHsBootFile mbinds + = hang (ptext SLIT("Bindings in hs-boot files are not allowed")) + 2 (ppr mbinds) + +nonStdGuardErr guards + = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")) + 4 (interpp'SP guards) +\end{code} diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs new file mode 100644 index 0000000000..2be3bfd5c0 --- /dev/null +++ b/compiler/rename/RnEnv.lhs @@ -0,0 +1,811 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[RnEnv]{Environment manipulation for the renamer monad} + +\begin{code} +module RnEnv ( + newTopSrcBinder, + lookupLocatedBndrRn, lookupBndrRn, + lookupLocatedTopBndrRn, lookupTopBndrRn, + lookupLocatedOccRn, lookupOccRn, + lookupLocatedGlobalOccRn, lookupGlobalOccRn, + lookupLocalDataTcNames, lookupSrcOcc_maybe, + lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, + lookupLocatedInstDeclBndr, + lookupSyntaxName, lookupSyntaxTable, lookupImportedName, + + newLocalsRn, newIPNameRn, + bindLocalNames, bindLocalNamesFV, + bindLocatedLocalsFV, bindLocatedLocalsRn, + bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV, + bindTyVarsRn, extendTyVarEnvFVRn, + bindLocalFixities, + + checkDupNames, mapFvRn, + warnUnusedMatches, warnUnusedModules, warnUnusedImports, + warnUnusedTopBinds, warnUnusedLocalBinds, + dataTcOccs, unknownNameErr, + ) where + +#include "HsVersions.h" + +import LoadIface ( loadHomeInterface, loadSrcInterface ) +import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) +import HsSyn ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable, + LHsTyVarBndr, LHsType, + Fixity, hsLTyVarLocNames, replaceTyVarName ) +import RdrHsSyn ( extractHsTyRdrTyVars ) +import RdrName ( RdrName, rdrNameModule, isQual, isUnqual, isOrig, + mkRdrUnqual, setRdrNameSpace, rdrNameOcc, + pprGlobalRdrEnv, lookupGRE_RdrName, + isExact_maybe, isSrcRdrName, + GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv, + isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv, + Provenance(..), pprNameProvenance, + importSpecLoc, importSpecModule + ) +import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) +import TcRnMonad +import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, + nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName ) +import NameSet +import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, + reportIfUnused ) +import Module ( Module ) +import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey ) +import UniqSupply +import BasicTypes ( IPName, mapIPName ) +import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc, + srcLocSpan, getLoc, combineSrcSpans, srcSpanStartLine, srcSpanEndLine ) +import Outputable +import Util ( sortLe ) +import ListSetOps ( removeDups ) +import List ( nubBy ) +import Monad ( when ) +import DynFlags +\end{code} + +%********************************************************* +%* * + Source-code binders +%* * +%********************************************************* + +\begin{code} +newTopSrcBinder :: Module -> Maybe Name -> Located RdrName -> RnM Name +newTopSrcBinder this_mod mb_parent (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 + ASSERT2( isExternalName name, ppr name ) + do checkErr (this_mod == nameModule name) + (badOrigBinding rdr_name) + returnM name + + + | isOrig rdr_name + = do checkErr (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) + (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 (rdrNameOcc rdr_name) mb_parent + (srcSpanStart loc) --TODO, should pass the whole span + + | otherwise + = newGlobalBinder this_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) + where + rdr_mod = rdrNameModule rdr_name +\end{code} + +%********************************************************* +%* * + Source code occurrences +%* * +%********************************************************* + +Looking up a name in the RnEnv. + +\begin{code} +lookupLocatedBndrRn :: Located RdrName -> RnM (Located Name) +lookupLocatedBndrRn = wrapLocM lookupBndrRn + +lookupBndrRn :: RdrName -> RnM Name +-- NOTE: assumes that the SrcSpan of the binder has already been setSrcSpan'd +lookupBndrRn rdr_name + = getLocalRdrEnv `thenM` \ local_env -> + case lookupLocalRdrEnv local_env rdr_name of + Just name -> returnM name + Nothing -> lookupTopBndrRn rdr_name + +lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) +lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn + +lookupTopBndrRn :: RdrName -> RnM 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 rdr_name + | Just name <- isExact_maybe rdr_name + = returnM name + + | isOrig rdr_name + -- This deals with the case of derived bindings, where + -- we don't bother to call newTopSrcBinder first + -- We assume there is no "parent" name + = do { loc <- getSrcSpanM + ; newGlobalBinder (rdrNameModule rdr_name) + (rdrNameOcc rdr_name) Nothing (srcSpanStart loc) } + + | otherwise + = do { mb_gre <- lookupGreLocalRn rdr_name + ; case mb_gre of + Nothing -> unboundName rdr_name + Just gre -> returnM (gre_name gre) } + +-- lookupLocatedSigOccRn 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 +lookupLocatedSigOccRn :: Located RdrName -> RnM (Located Name) +lookupLocatedSigOccRn = lookupLocatedBndrRn + +-- lookupInstDeclBndr is used for the binders in an +-- instance declaration. Here we use the class name to +-- disambiguate. + +lookupLocatedInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name) +lookupLocatedInstDeclBndr cls = wrapLocM (lookupInstDeclBndr cls) + +lookupInstDeclBndr :: Name -> RdrName -> RnM Name +lookupInstDeclBndr cls_name rdr_name + | isUnqual rdr_name -- Find all the things the rdr-name maps to + = do { -- and pick the one with the right parent name + let { is_op gre = cls_name == nameParent (gre_name gre) + ; occ = rdrNameOcc rdr_name + ; lookup_fn env = filter is_op (lookupGlobalRdrEnv env occ) } + ; mb_gre <- lookupGreRn_help rdr_name lookup_fn + ; case mb_gre of + Just gre -> return (gre_name gre) + Nothing -> do { addErr (unknownInstBndrErr cls_name rdr_name) + ; return (mkUnboundName rdr_name) } } + + | otherwise -- Occurs in derived instances, where we just + -- refer directly to the right method + = ASSERT2( not (isQual rdr_name), ppr rdr_name ) + -- NB: qualified names are rejected by the parser + lookupImportedName rdr_name + +newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name) +newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) + +-------------------------------------------------- +-- Occurrences +-------------------------------------------------- + +lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) +lookupLocatedOccRn = wrapLocM lookupOccRn + +-- lookupOccRn looks up an occurrence of a RdrName +lookupOccRn :: RdrName -> RnM Name +lookupOccRn rdr_name + = getLocalRdrEnv `thenM` \ local_env -> + case lookupLocalRdrEnv local_env rdr_name of + Just name -> returnM name + Nothing -> lookupGlobalOccRn rdr_name + +lookupLocatedGlobalOccRn :: Located RdrName -> RnM (Located Name) +lookupLocatedGlobalOccRn = wrapLocM lookupGlobalOccRn + +lookupGlobalOccRn :: RdrName -> RnM Name +-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global +-- environment. It's used only for +-- record field names +-- class op names in class and instance decls + +lookupGlobalOccRn rdr_name + | not (isSrcRdrName rdr_name) + = lookupImportedName rdr_name + + | otherwise + = -- First look up the name in the normal environment. + lookupGreRn rdr_name `thenM` \ mb_gre -> + case mb_gre of { + Just gre -> returnM (gre_name gre) ; + Nothing -> + + -- We allow qualified names on the command line to refer to + -- *any* name exported by any module in scope, just as if + -- there was an "import qualified M" declaration for every + -- module. + getModule `thenM` \ mod -> + if isQual rdr_name && mod == iNTERACTIVE then + -- This test is not expensive, + lookupQualifiedName rdr_name -- and only happens for failed lookups + else + unboundName rdr_name } + +lookupImportedName :: RdrName -> TcRnIf m n Name +-- Lookup the occurrence of an imported name +-- The RdrName is *always* qualified or Exact +-- Treat it as an original name, and conjure up the Name +-- Usually it's Exact or Orig, but it can be Qual if it +-- comes from an hi-boot file. (This minor infelicity is +-- just to reduce duplication in the parser.) +lookupImportedName rdr_name + | Just n <- isExact_maybe rdr_name + -- This happens in derived code + = returnM n + + | otherwise -- Always Orig, even when reading a .hi-boot file + = ASSERT( not (isUnqual rdr_name) ) + lookupOrig (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + +unboundName :: RdrName -> RnM Name +unboundName rdr_name + = do { addErr (unknownNameErr rdr_name) + ; env <- getGlobalRdrEnv; + ; traceRn (vcat [unknownNameErr rdr_name, + ptext SLIT("Global envt is:"), + nest 3 (pprGlobalRdrEnv env)]) + ; returnM (mkUnboundName rdr_name) } + +-------------------------------------------------- +-- Lookup in the Global RdrEnv of the module +-------------------------------------------------- + +lookupSrcOcc_maybe :: RdrName -> RnM (Maybe Name) +-- No filter function; does not report an error on failure +lookupSrcOcc_maybe rdr_name + = do { mb_gre <- lookupGreRn rdr_name + ; case mb_gre of + Nothing -> returnM Nothing + Just gre -> returnM (Just (gre_name gre)) } + +------------------------- +lookupGreRn :: RdrName -> RnM (Maybe GlobalRdrElt) +-- Just look up the RdrName in the GlobalRdrEnv +lookupGreRn rdr_name + = lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name) + +lookupGreLocalRn :: RdrName -> RnM (Maybe GlobalRdrElt) +-- Similar, but restricted to locally-defined things +lookupGreLocalRn rdr_name + = lookupGreRn_help rdr_name lookup_fn + where + lookup_fn env = filter isLocalGRE (lookupGRE_RdrName rdr_name env) + +lookupGreRn_help :: RdrName -- Only used in error message + -> (GlobalRdrEnv -> [GlobalRdrElt]) -- Lookup function + -> RnM (Maybe GlobalRdrElt) +-- Checks for exactly one match; reports deprecations +-- Returns Nothing, without error, if too few +lookupGreRn_help rdr_name lookup + = do { env <- getGlobalRdrEnv + ; case lookup env of + [] -> returnM Nothing + [gre] -> returnM (Just gre) + gres -> do { addNameClashErrRn rdr_name gres + ; returnM (Just (head gres)) } } + +------------------------------ +-- 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. +lookupQualifiedName :: RdrName -> RnM Name +lookupQualifiedName rdr_name + = let + mod = rdrNameModule rdr_name + occ = rdrNameOcc rdr_name + in + -- Note: we want to behave as we would for a source file import here, + -- and respect hiddenness of modules/packages, hence loadSrcInterface. + loadSrcInterface doc mod False `thenM` \ iface -> + + case [ (mod,occ) | + (mod,avails) <- mi_exports iface, + avail <- avails, + name <- availNames avail, + name == occ ] of + ((mod,occ):ns) -> ASSERT (null ns) + lookupOrig mod occ + _ -> unboundName rdr_name + where + doc = ptext SLIT("Need to find") <+> ppr rdr_name +\end{code} + +%********************************************************* +%* * + Fixities +%* * +%********************************************************* + +\begin{code} +lookupLocalDataTcNames :: RdrName -> RnM [Name] +-- GHC extension: look up both the tycon and data con +-- for con-like things +-- Complain if neither is in scope +lookupLocalDataTcNames rdr_name + | Just n <- isExact_maybe rdr_name + -- Special case for (:), which doesn't get into the GlobalRdrEnv + = return [n] -- For this we don't need to try the tycon too + | otherwise + = do { mb_gres <- mapM lookupGreLocalRn (dataTcOccs rdr_name) + ; case [gre_name gre | Just gre <- mb_gres] of + [] -> do { addErr (unknownNameErr rdr_name) + ; return [] } + names -> return names + } + +-------------------------------- +bindLocalFixities :: [FixitySig RdrName] -> RnM a -> RnM a +-- Used for nested fixity decls +-- No need to worry about type constructors here, +-- Should check for duplicates but we don't +bindLocalFixities fixes thing_inside + | null fixes = thing_inside + | otherwise = mappM rn_sig fixes `thenM` \ new_bit -> + extendFixityEnv new_bit thing_inside + where + rn_sig (FixitySig lv@(L loc v) fix) + = addLocM lookupBndrRn lv `thenM` \ new_v -> + returnM (new_v, (FixItem (rdrNameOcc v) fix loc)) +\end{code} + +-------------------------------- +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 HIT or 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 + +\begin{code} +lookupFixityRn :: Name -> RnM Fixity +lookupFixityRn name + = getModule `thenM` \ this_mod -> + if nameIsLocalOrFrom this_mod name + then -- It's defined in this module + getFixityEnv `thenM` \ local_fix_env -> + traceRn (text "lookupFixityRn" <+> (ppr name $$ ppr local_fix_env)) `thenM_` + returnM (lookupFixity local_fix_env name) + + else -- It's imported + -- For imported names, we have to get their fixities by doing a + -- loadHomeInterface, 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. + -- + -- loadHomeInterface will find B.hi even if B is a hidden module, + -- and that's what we want. + loadHomeInterface doc name `thenM` \ iface -> + returnM (mi_fix_fn iface (nameOccName name)) + where + doc = ptext SLIT("Checking fixity for") <+> ppr name + +--------------- +lookupTyFixityRn :: Located Name -> RnM Fixity +lookupTyFixityRn (L loc n) + = doptM Opt_GlasgowExts `thenM` \ glaExts -> + when (not glaExts) + (setSrcSpan loc $ addWarn (infixTyConWarn n)) `thenM_` + lookupFixityRn n + +--------------- +dataTcOccs :: RdrName -> [RdrName] +-- If the input is a data constructor, return both it and a type +-- constructor. This is useful when we aren't sure which we are +-- looking at. +dataTcOccs rdr_name + | Just n <- isExact_maybe rdr_name -- Ghastly special case + , n `hasKey` consDataConKey = [rdr_name] -- see note below + | isDataOcc occ = [rdr_name_tc, rdr_name] + | otherwise = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = setRdrNameSpace rdr_name tcName + +-- If the user typed "[]" or "(,,)", we'll generate an Exact RdrName, +-- and setRdrNameSpace generates an Orig, which is fine +-- But it's not fine for (:), because there *is* no corresponding type +-- constructor. If we generate an Orig tycon for GHC.Base.(:), it'll +-- appear to be in scope (because Orig's simply allocate a new name-cache +-- entry) and then we get an error when we use dataTcOccs in +-- TcRnDriver.tcRnGetInfo. Large sigh. +\end{code} + +%************************************************************************ +%* * + Rebindable names + Dealing with rebindable syntax is driven by the + Opt_NoImplicitPrelude 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 + * 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 orignal (standard) names as free-vars too, because the type checker +checks the type of the user thing against the type of the standard thing. + +\begin{code} +lookupSyntaxName :: Name -- The standard name + -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name +lookupSyntaxName std_name + = doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude -> + if implicit_prelude then normal_case + else + -- Get the similarly named thing from the local environment + lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name -> + returnM (HsVar usr_name, unitFV usr_name) + where + normal_case = returnM (HsVar std_name, emptyFVs) + +lookupSyntaxTable :: [Name] -- Standard names + -> RnM (SyntaxTable Name, FreeVars) -- See comments with HsExpr.ReboundNames +lookupSyntaxTable std_names + = doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude -> + if implicit_prelude then normal_case + else + -- Get the similarly named thing from the local environment + mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names -> + + returnM (std_names `zip` map HsVar usr_names, mkFVs usr_names) + where + normal_case = returnM (std_names `zip` map HsVar std_names, emptyFVs) +\end{code} + + +%********************************************************* +%* * +\subsection{Binding} +%* * +%********************************************************* + +\begin{code} +newLocalsRn :: [Located RdrName] -> RnM [Name] +newLocalsRn rdr_names_w_loc + = newUniqueSupply `thenM` \ us -> + returnM (zipWith mk rdr_names_w_loc (uniqsFromSupply us)) + where + mk (L loc rdr_name) uniq + | Just name <- isExact_maybe rdr_name = name + -- This happens in code generated by Template Haskell + | otherwise = ASSERT2( isUnqual rdr_name, ppr rdr_name ) + -- We only bind unqualified names here + -- lookupRdrEnv doesn't even attempt to look up a qualified RdrName + mkInternalName uniq (rdrNameOcc rdr_name) (srcSpanStart loc) + +bindLocatedLocalsRn :: SDoc -- Documentation string for error message + -> [Located RdrName] + -> ([Name] -> RnM a) + -> RnM a +bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope + = -- Check for duplicate names + checkDupNames doc_str rdr_names_w_loc `thenM_` + + -- Warn about shadowing, but only in source modules + ifOptM Opt_WarnNameShadowing + (checkShadowing doc_str rdr_names_w_loc) `thenM_` + + -- Make fresh Names and extend the environment + newLocalsRn rdr_names_w_loc `thenM` \ names -> + getLocalRdrEnv `thenM` \ local_env -> + setLocalRdrEnv (extendLocalRdrEnv local_env names) + (enclosed_scope names) + + +bindLocalNames :: [Name] -> RnM a -> RnM a +bindLocalNames names enclosed_scope + = getLocalRdrEnv `thenM` \ name_env -> + setLocalRdrEnv (extendLocalRdrEnv name_env names) + enclosed_scope + +bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) +bindLocalNamesFV names enclosed_scope + = do { (result, fvs) <- bindLocalNames names enclosed_scope + ; returnM (result, delListFromNameSet fvs names) } + + +------------------------------------- + -- binLocalsFVRn is the same as bindLocalsRn + -- except that it deals with free vars +bindLocatedLocalsFV :: SDoc -> [Located RdrName] -> ([Name] -> RnM (a,FreeVars)) + -> RnM (a, FreeVars) +bindLocatedLocalsFV doc rdr_names enclosed_scope + = bindLocatedLocalsRn doc rdr_names $ \ names -> + enclosed_scope names `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs names) + +------------------------------------- +bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName] + -> ([LHsTyVarBndr Name] -> RnM a) + -> RnM a +-- Haskell-98 binding of type variables; e.g. within a data type decl +bindTyVarsRn doc_str tyvar_names enclosed_scope + = let + located_tyvars = hsLTyVarLocNames tyvar_names + in + bindLocatedLocalsRn doc_str located_tyvars $ \ names -> + enclosed_scope (zipWith replace tyvar_names names) + where + replace (L loc n1) n2 = L loc (replaceTyVarName n1 n2) + +bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a + -- Find the type variables in the pattern type + -- signatures that must be brought into scope +bindPatSigTyVars tys thing_inside + = do { scoped_tyvars <- doptM Opt_ScopedTypeVariables + ; if not scoped_tyvars then + thing_inside [] + else + do { name_env <- getLocalRdrEnv + ; let locd_tvs = [ tv | ty <- tys + , tv <- extractHsTyRdrTyVars ty + , not (unLoc tv `elemLocalRdrEnv` name_env) ] + nubbed_tvs = nubBy eqLocated locd_tvs + -- The 'nub' is important. For example: + -- f (x :: t) (y :: t) = .... + -- We don't want to complain about binding t twice! + + ; bindLocatedLocalsRn doc_sig nubbed_tvs thing_inside }} + where + doc_sig = text "In a pattern type-signature" + +bindPatSigTyVarsFV :: [LHsType RdrName] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +bindPatSigTyVarsFV tys thing_inside + = bindPatSigTyVars tys $ \ tvs -> + thing_inside `thenM` \ (result,fvs) -> + returnM (result, fvs `delListFromNameSet` tvs) + +bindSigTyVarsFV :: [Name] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +bindSigTyVarsFV tvs thing_inside + = do { scoped_tyvars <- doptM Opt_ScopedTypeVariables + ; if not scoped_tyvars then + thing_inside + else + bindLocalNamesFV tvs thing_inside } + +extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) + -- This function is used only in rnSourceDecl on InstDecl +extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside + +------------------------------------- +checkDupNames :: SDoc + -> [Located RdrName] + -> RnM () +checkDupNames doc_str rdr_names_w_loc + = -- Check for duplicated names in a binding group + mappM_ (dupNamesErr doc_str) dups + where + (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc + +------------------------------------- +checkShadowing doc_str loc_rdr_names + = getLocalRdrEnv `thenM` \ local_env -> + getGlobalRdrEnv `thenM` \ global_env -> + let + check_shadow (L loc rdr_name) + | rdr_name `elemLocalRdrEnv` local_env + || not (null (lookupGRE_RdrName rdr_name global_env )) + = setSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name) + | otherwise = returnM () + in + mappM_ check_shadow loc_rdr_names +\end{code} + + +%************************************************************************ +%* * +\subsection{Free variable manipulation} +%* * +%************************************************************************ + +\begin{code} +-- A useful utility +mapFvRn f xs = mappM f xs `thenM` \ stuff -> + let + (ys, fvs_s) = unzip stuff + in + returnM (ys, plusFVs fvs_s) +\end{code} + + +%************************************************************************ +%* * +\subsection{Envt utility functions} +%* * +%************************************************************************ + +\begin{code} +warnUnusedModules :: [(Module,SrcSpan)] -> RnM () +warnUnusedModules mods + = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods) + where + bleat (mod,loc) = setSrcSpan loc $ addWarn (mk_warn mod) + mk_warn m = vcat [ptext SLIT("Module") <+> quotes (ppr m) + <+> text "is imported, but nothing from it is used,", + nest 2 (ptext SLIT("except perhaps instances visible in") + <+> quotes (ppr m)), + ptext SLIT("To suppress this warning, use:") + <+> ptext SLIT("import") <+> ppr m <> parens empty ] + + +warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () +warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres) +warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds (warnUnusedGREs gres) + +warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM () +warnUnusedLocalBinds names = ifOptM Opt_WarnUnusedBinds (warnUnusedLocals names) +warnUnusedMatches names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals names) + +------------------------- +-- Helpers +warnUnusedGREs gres + = warnUnusedBinds [(n,Just p) | GRE {gre_name = n, gre_prov = p} <- gres] + +warnUnusedLocals names + = warnUnusedBinds [(n,Nothing) | n<-names] + +warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM () +warnUnusedBinds names = mappM_ warnUnusedName (filter reportable names) + where reportable (name,_) + | isWiredInName name = False -- Don't report unused wired-in names + -- Otherwise we get a zillion warnings + -- from Data.Tuple + | otherwise = reportIfUnused (nameOccName name) + +------------------------- + +warnUnusedName :: (Name, Maybe Provenance) -> RnM () +warnUnusedName (name, prov) + = addWarnAt loc $ + sep [msg <> colon, + nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name)) + <+> quotes (ppr name)] + -- TODO should be a proper span + where + (loc,msg) = case prov of + Just (Imported is) + -> (importSpecLoc imp_spec, imp_from (importSpecModule imp_spec)) + where + imp_spec = head is + other -> (srcLocSpan (nameSrcLoc name), unused_msg) + + unused_msg = text "Defined but not used" + imp_from mod = text "Imported from" <+> quotes (ppr mod) <+> text "but not used" +\end{code} + +\begin{code} +addNameClashErrRn rdr_name (np1:nps) + = addErr (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), + ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) + where + msg1 = ptext SLIT("either") <+> mk_ref np1 + msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] + mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre + +shadowedNameWarn doc shadow + = hsep [ptext SLIT("This binding for"), + quotes (ppr shadow), + ptext SLIT("shadows an existing binding")] + $$ doc + +unknownNameErr rdr_name + = sep [ptext SLIT("Not in scope:"), + nest 2 $ pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) + <+> quotes (ppr rdr_name)] + +unknownInstBndrErr cls op + = quotes (ppr op) <+> ptext SLIT("is not a (visible) method of class") <+> quotes (ppr cls) + +badOrigBinding name + = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) + -- The rdrNameOcc is because we don't want to print Prelude.(,) + +dupNamesErr :: SDoc -> [Located RdrName] -> RnM () +dupNamesErr descriptor located_names + = setSrcSpan big_loc $ + addErr (vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr name1), + locations, + descriptor]) + where + L _ name1 = head located_names + locs = map getLoc located_names + big_loc = foldr1 combineSrcSpans locs + one_line = srcSpanStartLine big_loc == srcSpanEndLine big_loc + locations | one_line = empty + | otherwise = ptext SLIT("Bound at:") <+> + vcat (map ppr (sortLe (<=) locs)) + +infixTyConWarn op + = vcat [ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op), + ftext FSLIT("Use -fglasgow-exts to avoid this warning")] +\end{code} diff --git a/compiler/rename/RnExpr.hi-boot-6 b/compiler/rename/RnExpr.hi-boot-6 new file mode 100644 index 0000000000..8f6c7f154b --- /dev/null +++ b/compiler/rename/RnExpr.hi-boot-6 @@ -0,0 +1,11 @@ +module RnExpr where
+
+rnLExpr :: HsExpr.LHsExpr RdrName.RdrName
+ -> TcRnTypes.RnM (HsExpr.LHsExpr Name.Name, NameSet.FreeVars)
+
+rnStmts :: forall thing.
+ HsExpr.HsStmtContext Name.Name -> [HsExpr.LStmt RdrName.RdrName]
+ -> TcRnTypes.RnM (thing, NameSet.FreeVars)
+ -> TcRnTypes.RnM (([HsExpr.LStmt Name.Name], thing), NameSet.FreeVars)
+
+
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs new file mode 100644 index 0000000000..716a85a3b3 --- /dev/null +++ b/compiler/rename/RnExpr.lhs @@ -0,0 +1,996 @@ +% +% (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. + +\begin{code} +module RnExpr ( + rnLExpr, rnExpr, rnStmts + ) where + +#include "HsVersions.h" + +import RnSource ( rnSrcDecls, rnSplice, checkTH ) +import RnBinds ( rnLocalBindsAndThen, rnValBinds, + rnMatchGroup, trimWith ) +import HsSyn +import RnHsSyn +import TcRnMonad +import RnEnv +import OccName ( plusOccEnv ) +import RnNames ( getLocalDeclBinders, extendRdrEnvRn ) +import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit, + mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec, + dupFieldErr, checkTupSize ) +import DynFlags ( DynFlag(..) ) +import BasicTypes ( FixityDirection(..) ) +import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName, + loopAName, choiceAName, appAName, arrAName, composeAName, firstAName, + negateName, thenMName, bindMName, failMName ) +#if defined(GHCI) && defined(BREAKPOINT) +import PrelNames ( breakpointJumpName, undefined_RDR, breakpointIdKey ) +import UniqFM ( eltsUFM ) +import DynFlags ( GhcMode(..) ) +import SrcLoc ( srcSpanFile, srcSpanStartLine ) +import Name ( isTyVarName ) +#endif +import Name ( Name, nameOccName, nameIsLocalOrFrom ) +import NameSet +import RdrName ( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv ) +import LoadIface ( loadHomeInterface ) +import UniqFM ( isNullUFM ) +import UniqSet ( emptyUniqSet ) +import List ( nub ) +import Util ( isSingleton ) +import ListSetOps ( removeDups ) +import Maybes ( expectJust ) +import Outputable +import SrcLoc ( Located(..), unLoc, getLoc, cmpLocated ) +import FastString + +import List ( unzip4 ) +\end{code} + + +%************************************************************************ +%* * +\subsubsection{Expressions} +%* * +%************************************************************************ + +\begin{code} +rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars) +rnExprs ls = rnExprs' ls emptyUniqSet + where + rnExprs' [] acc = returnM ([], acc) + rnExprs' (expr:exprs) acc + = rnLExpr expr `thenM` \ (expr', fvExpr) -> + + -- 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 + in + (grubby_seqNameSet acc' rnExprs') exprs acc' `thenM` \ (exprs', fvExprs) -> + returnM (expr':exprs', fvExprs) + +-- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq +grubby_seqNameSet ns result | isNullUFM ns = result + | otherwise = result +\end{code} + +Variables. We look up the variable and return the resulting name. + +\begin{code} +rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars) +rnLExpr = wrapLocFstM rnExpr + +rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) + +rnExpr (HsVar v) + = do name <- lookupOccRn v + localRdrEnv <- getLocalRdrEnv + lclEnv <- getLclEnv + ignore_asserts <- doptM Opt_IgnoreAsserts + ignore_breakpoints <- doptM Opt_IgnoreBreakpoints + let conds = [ (name `hasKey` assertIdKey + && not ignore_asserts, + do (e, fvs) <- mkAssertErrorExpr + return (e, fvs `addOneFV` name)) +#if defined(GHCI) && defined(BREAKPOINT) + , (name `hasKey` breakpointIdKey + && not ignore_breakpoints, + do ghcMode <- getGhcMode + case ghcMode of + Interactive + -> do let isWantedName = not.isTyVarName + (e, fvs) <- mkBreakPointExpr (filter isWantedName (eltsUFM localRdrEnv)) + return (e, fvs `addOneFV` name) + _ -> return (HsVar name, unitFV name) + ) +#endif + ] + case lookup True conds of + Just action -> action + Nothing -> return (HsVar name, unitFV name) + +rnExpr (HsIPVar v) + = newIPNameRn v `thenM` \ name -> + returnM (HsIPVar name, emptyFVs) + +rnExpr (HsLit lit) + = rnLit lit `thenM_` + returnM (HsLit lit, emptyFVs) + +rnExpr (HsOverLit lit) + = rnOverLit lit `thenM` \ (lit', fvs) -> + returnM (HsOverLit lit', fvs) + +rnExpr (HsApp fun arg) + = rnLExpr fun `thenM` \ (fun',fvFun) -> + rnLExpr arg `thenM` \ (arg',fvArg) -> + returnM (HsApp fun' arg', fvFun `plusFV` fvArg) + +rnExpr (OpApp e1 op _ e2) + = rnLExpr e1 `thenM` \ (e1', fv_e1) -> + rnLExpr e2 `thenM` \ (e2', fv_e2) -> + rnLExpr op `thenM` \ (op'@(L _ (HsVar op_name)), fv_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. + lookupFixityRn op_name `thenM` \ fixity -> + mkOpAppRn e1' op' fixity e2' `thenM` \ final_e -> + + returnM (final_e, + fv_e1 `plusFV` fv_op `plusFV` fv_e2) + +rnExpr (NegApp e _) + = rnLExpr e `thenM` \ (e', fv_e) -> + lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) -> + mkNegAppRn e' neg_name `thenM` \ final_e -> + returnM (final_e, fv_e `plusFV` fv_neg) + +rnExpr (HsPar e) + = rnLExpr e `thenM` \ (e', fvs_e) -> + returnM (HsPar e', fvs_e) + +-- Template Haskell extensions +-- Don't ifdef-GHCI them because we want to fail gracefully +-- (not with an rnExpr crash) in a stage-1 compiler. +rnExpr e@(HsBracket br_body) + = checkTH e "bracket" `thenM_` + rnBracket br_body `thenM` \ (body', fvs_e) -> + returnM (HsBracket body', fvs_e) + +rnExpr e@(HsSpliceE splice) + = rnSplice splice `thenM` \ (splice', fvs) -> + returnM (HsSpliceE splice', fvs) + +rnExpr section@(SectionL expr op) + = rnLExpr expr `thenM` \ (expr', fvs_expr) -> + rnLExpr op `thenM` \ (op', fvs_op) -> + checkSectionPrec InfixL section op' expr' `thenM_` + returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr) + +rnExpr section@(SectionR op expr) + = rnLExpr op `thenM` \ (op', fvs_op) -> + rnLExpr expr `thenM` \ (expr', fvs_expr) -> + checkSectionPrec InfixR section op' expr' `thenM_` + returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr) + +rnExpr (HsCoreAnn ann expr) + = rnLExpr expr `thenM` \ (expr', fvs_expr) -> + returnM (HsCoreAnn ann expr', fvs_expr) + +rnExpr (HsSCC lbl expr) + = rnLExpr expr `thenM` \ (expr', fvs_expr) -> + returnM (HsSCC lbl expr', fvs_expr) + +rnExpr (HsLam matches) + = rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) -> + returnM (HsLam matches', fvMatch) + +rnExpr (HsCase expr matches) + = rnLExpr expr `thenM` \ (new_expr, e_fvs) -> + rnMatchGroup CaseAlt matches `thenM` \ (new_matches, ms_fvs) -> + returnM (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) + +rnExpr (HsLet binds expr) + = rnLocalBindsAndThen binds $ \ binds' -> + rnLExpr expr `thenM` \ (expr',fvExpr) -> + returnM (HsLet binds' expr', fvExpr) + +rnExpr e@(HsDo do_or_lc stmts body _) + = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $ + rnLExpr body + ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) } + +rnExpr (ExplicitList _ exps) + = rnExprs exps `thenM` \ (exps', fvs) -> + returnM (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name) + +rnExpr (ExplicitPArr _ exps) + = rnExprs exps `thenM` \ (exps', fvs) -> + returnM (ExplicitPArr placeHolderType exps', fvs) + +rnExpr e@(ExplicitTuple exps boxity) + = checkTupSize tup_size `thenM_` + rnExprs exps `thenM` \ (exps', fvs) -> + returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name) + where + tup_size = length exps + tycon_name = tupleTyCon_name boxity tup_size + +rnExpr (RecordCon con_id _ rbinds) + = lookupLocatedOccRn con_id `thenM` \ conname -> + rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) -> + returnM (RecordCon conname noPostTcExpr rbinds', + fvRbinds `addOneFV` unLoc conname) + +rnExpr (RecordUpd expr rbinds _ _) + = rnLExpr expr `thenM` \ (expr', fvExpr) -> + rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) -> + returnM (RecordUpd expr' rbinds' placeHolderType placeHolderType, + fvExpr `plusFV` fvRbinds) + +rnExpr (ExprWithTySig expr pty) + = rnLExpr expr `thenM` \ (expr', fvExpr) -> + rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) -> + returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) + where + doc = text "In an expression type signature" + +rnExpr (HsIf p b1 b2) + = rnLExpr p `thenM` \ (p', fvP) -> + rnLExpr b1 `thenM` \ (b1', fvB1) -> + rnLExpr b2 `thenM` \ (b2', fvB2) -> + returnM (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2]) + +rnExpr (HsType a) + = rnHsTypeFVs doc a `thenM` \ (t, fvT) -> + returnM (HsType t, fvT) + where + doc = text "In a type argument" + +rnExpr (ArithSeq _ seq) + = rnArithSeq seq `thenM` \ (new_seq, fvs) -> + returnM (ArithSeq noPostTcExpr new_seq, fvs) + +rnExpr (PArrSeq _ seq) + = rnArithSeq seq `thenM` \ (new_seq, fvs) -> + returnM (PArrSeq noPostTcExpr new_seq, fvs) +\end{code} + +These three are pattern syntax appearing in expressions. +Since all the symbols are reservedops we can simply reject them. +We return a (bogus) EWildPat in each case. + +\begin{code} +rnExpr e@EWildPat = patSynErr e +rnExpr e@(EAsPat {}) = patSynErr e +rnExpr e@(ELazyPat {}) = patSynErr e +\end{code} + +%************************************************************************ +%* * + Arrow notation +%* * +%************************************************************************ + +\begin{code} +rnExpr (HsProc pat body) + = newArrowScope $ + rnPatsAndThen ProcExpr [pat] $ \ [pat'] -> + rnCmdTop body `thenM` \ (body',fvBody) -> + returnM (HsProc pat' body', fvBody) + +rnExpr (HsArrApp arrow arg _ ho rtl) + = select_arrow_scope (rnLExpr arrow) `thenM` \ (arrow',fvArrow) -> + rnLExpr arg `thenM` \ (arg',fvArg) -> + returnM (HsArrApp arrow' arg' placeHolderType ho rtl, + fvArrow `plusFV` fvArg) + where + select_arrow_scope tc = case ho of + HsHigherOrderApp -> tc + HsFirstOrderApp -> escapeArrowScope tc + +-- infix form +rnExpr (HsArrForm op (Just _) [arg1, arg2]) + = escapeArrowScope (rnLExpr op) + `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) -> + rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) -> + rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) -> + + -- Deal with fixity + + lookupFixityRn op_name `thenM` \ fixity -> + mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e -> + + returnM (final_e, + fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) + +rnExpr (HsArrForm op fixity cmds) + = escapeArrowScope (rnLExpr op) `thenM` \ (op',fvOp) -> + rnCmdArgs cmds `thenM` \ (cmds',fvCmds) -> + returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds) + +rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) + -- DictApp, DictLam, TyApp, TyLam +\end{code} + + +%************************************************************************ +%* * + Arrow commands +%* * +%************************************************************************ + +\begin{code} +rnCmdArgs [] = returnM ([], emptyFVs) +rnCmdArgs (arg:args) + = rnCmdTop arg `thenM` \ (arg',fvArg) -> + rnCmdArgs args `thenM` \ (args',fvArgs) -> + returnM (arg':args', fvArg `plusFV` fvArgs) + + +rnCmdTop = wrapLocFstM rnCmdTop' + where + rnCmdTop' (HsCmdTop cmd _ _ _) + = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) -> + let + cmd_names = [arrAName, composeAName, firstAName] ++ + nameSetToList (methodNamesCmd (unLoc cmd')) + in + -- Generate the rebindable syntax for the monad + lookupSyntaxTable cmd_names `thenM` \ (cmd_names', cmd_fvs) -> + + returnM (HsCmdTop cmd' [] placeHolderType cmd_names', + fvCmd `plusFV` cmd_fvs) + +--------------------------------------------------- +-- convert OpApp's in a command context to HsArrForm's + +convertOpFormsLCmd :: LHsCmd id -> LHsCmd id +convertOpFormsLCmd = fmap convertOpFormsCmd + +convertOpFormsCmd :: HsCmd id -> HsCmd id + +convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e +convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match) +convertOpFormsCmd (OpApp c1 op fixity c2) + = let + arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType [] + arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType [] + in + HsArrForm op (Just fixity) [arg1, arg2] + +convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c) + +-- gaw 2004 +convertOpFormsCmd (HsCase exp matches) + = HsCase exp (convertOpFormsMatch matches) + +convertOpFormsCmd (HsIf exp c1 c2) + = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2) + +convertOpFormsCmd (HsLet binds cmd) + = HsLet binds (convertOpFormsLCmd cmd) + +convertOpFormsCmd (HsDo ctxt stmts body ty) + = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) + (convertOpFormsLCmd body) ty + +-- Anything else is unchanged. This includes HsArrForm (already done), +-- things with no sub-commands, and illegal commands (which will be +-- caught by the type checker) +convertOpFormsCmd c = c + +convertOpFormsStmt (BindStmt pat cmd _ _) + = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr +convertOpFormsStmt (ExprStmt cmd _ _) + = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType +convertOpFormsStmt (RecStmt stmts lvs rvs es binds) + = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es binds +convertOpFormsStmt stmt = stmt + +convertOpFormsMatch (MatchGroup ms ty) + = MatchGroup (map (fmap convert) ms) ty + where convert (Match pat mty grhss) + = Match pat mty (convertOpFormsGRHSs grhss) + +convertOpFormsGRHSs (GRHSs grhss binds) + = GRHSs (map convertOpFormsGRHS grhss) binds + +convertOpFormsGRHS = fmap convert + where + convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd) + +--------------------------------------------------- +type CmdNeeds = FreeVars -- Only inhabitants are + -- appAName, choiceAName, loopAName + +-- find what methods the Cmd needs (loop, choice, apply) +methodNamesLCmd :: LHsCmd Name -> CmdNeeds +methodNamesLCmd = methodNamesCmd . unLoc + +methodNamesCmd :: HsCmd Name -> CmdNeeds + +methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsFirstOrderApp _rtl) + = emptyFVs +methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsHigherOrderApp _rtl) + = unitFV appAName +methodNamesCmd cmd@(HsArrForm {}) = emptyFVs + +methodNamesCmd (HsPar c) = methodNamesLCmd c + +methodNamesCmd (HsIf p c1 c2) + = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName + +methodNamesCmd (HsLet b c) = methodNamesLCmd c + +methodNamesCmd (HsDo sc stmts body ty) + = methodNamesStmts stmts `plusFV` methodNamesLCmd body + +methodNamesCmd (HsApp c e) = methodNamesLCmd c + +methodNamesCmd (HsLam match) = methodNamesMatch match + +methodNamesCmd (HsCase scrut matches) + = methodNamesMatch matches `addOneFV` choiceAName + +methodNamesCmd other = 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 ms ty) + = plusFVs (map do_one ms) + where + do_one (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss + +------------------------------------------------- +-- gaw 2004 +methodNamesGRHSs (GRHSs grhss binds) = plusFVs (map methodNamesGRHS grhss) + +------------------------------------------------- +methodNamesGRHS (L _ (GRHS stmts rhs)) = methodNamesLCmd rhs + +--------------------------------------------------- +methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts) + +--------------------------------------------------- +methodNamesLStmt = methodNamesStmt . unLoc + +methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd +methodNamesStmt (BindStmt pat cmd _ _) = methodNamesLCmd cmd +methodNamesStmt (RecStmt stmts _ _ _ _) + = methodNamesStmts stmts `addOneFV` loopAName +methodNamesStmt (LetStmt b) = emptyFVs +methodNamesStmt (ParStmt ss) = emptyFVs + -- ParStmt can't occur in commands, but it's not convenient to error + -- here so we just do what's convenient +\end{code} + + +%************************************************************************ +%* * + Arithmetic sequences +%* * +%************************************************************************ + +\begin{code} +rnArithSeq (From expr) + = rnLExpr expr `thenM` \ (expr', fvExpr) -> + returnM (From expr', fvExpr) + +rnArithSeq (FromThen expr1 expr2) + = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> + returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) + +rnArithSeq (FromTo expr1 expr2) + = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> + returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) + +rnArithSeq (FromThenTo expr1 expr2 expr3) + = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> + rnLExpr expr3 `thenM` \ (expr3', fvExpr3) -> + returnM (FromThenTo expr1' expr2' expr3', + plusFVs [fvExpr1, fvExpr2, fvExpr3]) +\end{code} + + +%************************************************************************ +%* * +\subsubsection{@Rbinds@s and @Rpats@s: in record expressions} +%* * +%************************************************************************ + +\begin{code} +rnRbinds str rbinds + = mappM_ field_dup_err dup_fields `thenM_` + mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) -> + returnM (rbinds', fvRbind) + where + (_, dup_fields) = removeDups cmpLocated [ f | (f,_) <- rbinds ] + + field_dup_err dups = mappM_ (\f -> addLocErr f (dupFieldErr str)) dups + + rn_rbind (field, expr) + = lookupLocatedGlobalOccRn field `thenM` \ fieldname -> + rnLExpr expr `thenM` \ (expr', fvExpr) -> + returnM ((fieldname, expr'), fvExpr `addOneFV` unLoc fieldname) +\end{code} + +%************************************************************************ +%* * + Template Haskell brackets +%* * +%************************************************************************ + +\begin{code} +rnBracket (VarBr n) = do { name <- lookupOccRn n + ; this_mod <- getModule + ; checkM (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the + do { loadHomeInterface msg name -- home interface is loaded, and this is the + ; return () } -- only way that is going to happen + ; returnM (VarBr name, unitFV name) } + where + msg = ptext SLIT("Need interface for Template Haskell quoted Name") + +rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e + ; return (ExpBr e', fvs) } +rnBracket (PatBr p) = do { (p', fvs) <- rnLPat p + ; return (PatBr p', fvs) } +rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t + ; return (TypBr t', fvs) } + where + doc = ptext SLIT("In a Template-Haskell quoted type") +rnBracket (DecBr group) + = do { gbl_env <- getGblEnv + + ; let gbl_env1 = gbl_env { tcg_mod = thFAKE } + -- Note the thFAKE. The top-level names from the bracketed + -- declarations will go into the name cache, and we don't want them to + -- confuse the Names for the current module. + -- By using a pretend module, thFAKE, we keep them safely out of the way. + + ; names <- getLocalDeclBinders gbl_env1 group + ; rdr_env' <- extendRdrEnvRn emptyGlobalRdrEnv names + -- Furthermore, the names in the bracket shouldn't conflict with + -- existing top-level names E.g. + -- foo = 1 + -- bar = [d| foo = 1|] + -- But both 'foo's get a LocalDef provenance, so we'd get a complaint unless + -- we start with an emptyGlobalRdrEnv + + ; setGblEnv (gbl_env { tcg_rdr_env = tcg_rdr_env gbl_env1 `plusOccEnv` rdr_env', + tcg_dus = emptyDUs }) $ do + -- Notice plusOccEnv, not plusGlobalRdrEnv. In this situation we want + -- to *shadow* top-level bindings. (See the 'foo' example above.) + -- If we don't shadow, we'll get an ambiguity complaint when we do + -- a lookupTopBndrRn (which uses lookupGreLocalRn) on the binder of the 'foo' + -- + -- Furthermore, arguably if the splice does define foo, that should hide + -- any foo's further out + -- + -- The emptyDUs is so that we just collect uses for this group alone + + { (tcg_env, group') <- rnSrcDecls group + -- Discard the tcg_env; it contains only extra info about fixity + ; return (DecBr group', allUses (tcg_dus tcg_env)) } } +\end{code} + +%************************************************************************ +%* * +\subsubsection{@Stmt@s: in @do@ expressions} +%* * +%************************************************************************ + +\begin{code} +rnStmts :: HsStmtContext Name -> [LStmt RdrName] + -> RnM (thing, FreeVars) + -> RnM (([LStmt Name], thing), FreeVars) + +rnStmts (MDoExpr _) = rnMDoStmts +rnStmts ctxt = rnNormalStmts ctxt + +rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName] + -> RnM (thing, FreeVars) + -> RnM (([LStmt Name], thing), FreeVars) +-- Used for cases *other* than recursive mdo +-- Implements nested scopes + +rnNormalStmts ctxt [] thing_inside + = do { (thing, fvs) <- thing_inside + ; return (([],thing), fvs) } + +rnNormalStmts ctxt (L loc stmt : stmts) thing_inside + = do { ((stmt', (stmts', thing)), fvs) + <- rnStmt ctxt stmt $ + rnNormalStmts ctxt stmts thing_inside + ; return (((L loc stmt' : stmts'), thing), fvs) } + +rnStmt :: HsStmtContext Name -> Stmt RdrName + -> RnM (thing, FreeVars) + -> RnM ((Stmt Name, thing), FreeVars) + +rnStmt ctxt (ExprStmt expr _ _) thing_inside + = do { (expr', fv_expr) <- rnLExpr expr + ; (then_op, fvs1) <- lookupSyntaxName thenMName + ; (thing, fvs2) <- thing_inside + ; return ((ExprStmt expr' then_op placeHolderType, thing), + fv_expr `plusFV` fvs1 `plusFV` fvs2) } + +rnStmt ctxt (BindStmt pat expr _ _) thing_inside + = do { (expr', fv_expr) <- rnLExpr expr + -- The binders do not scope over the expression + ; (bind_op, fvs1) <- lookupSyntaxName bindMName + ; (fail_op, fvs2) <- lookupSyntaxName failMName + ; rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] -> do + { (thing, fvs3) <- thing_inside + ; return ((BindStmt pat' expr' bind_op fail_op, 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 ctxt (LetStmt binds) thing_inside + = do { checkErr (ok ctxt binds) + (badIpBinds (ptext SLIT("a parallel list comprehension:")) binds) + ; rnLocalBindsAndThen binds $ \ binds' -> do + { (thing, fvs) <- thing_inside + ; return ((LetStmt binds', thing), fvs) }} + where + -- We do not allow implicit-parameter bindings in a parallel + -- list comprehension. I'm not sure what it might mean. + ok (ParStmtCtxt _) (HsIPBinds _) = False + ok _ _ = True + +rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside + = bindLocatedLocalsRn doc (collectLStmtsBinders rec_stmts) $ \ bndrs -> + rn_rec_stmts bndrs rec_stmts `thenM` \ segs -> + thing_inside `thenM` \ (thing, fvs) -> + let + segs_w_fwd_refs = addFwdRefs segs + (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs + later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs) + fwd_vars = nameSetToList (plusFVs fs) + uses = plusFVs us + rec_stmt = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds + in + returnM ((rec_stmt, thing), uses `plusFV` fvs) + where + doc = text "In a recursive do statement" + +rnStmt ctxt (ParStmt segs) thing_inside + = do { opt_GlasgowExts <- doptM Opt_GlasgowExts + ; checkM opt_GlasgowExts parStmtErr + ; orig_lcl_env <- getLocalRdrEnv + ; ((segs',thing), fvs) <- go orig_lcl_env [] segs + ; return ((ParStmt segs', thing), fvs) } + where +-- type ParSeg id = [([LStmt id], [id])] +-- go :: NameSet -> [ParSeg RdrName] +-- -> RnM (([ParSeg Name], thing), FreeVars) + + go orig_lcl_env bndrs [] + = do { let { (bndrs', dups) = removeDups cmpByOcc bndrs + ; inner_env = extendLocalRdrEnv orig_lcl_env bndrs' } + ; mappM dupErr dups + ; (thing, fvs) <- setLocalRdrEnv inner_env thing_inside + ; return (([], thing), fvs) } + + go orig_lcl_env bndrs_so_far ((stmts, _) : segs) + = do { ((stmts', (bndrs, segs', thing)), fvs) + <- rnNormalStmts par_ctxt stmts $ do + { -- Find the Names that are bound by stmts + lcl_env <- getLocalRdrEnv + ; let { rdr_bndrs = collectLStmtsBinders stmts + ; bndrs = map ( expectJust "rnStmt" + . lookupLocalRdrEnv lcl_env + . unLoc) rdr_bndrs + ; new_bndrs = nub bndrs ++ bndrs_so_far + -- The nub is because there might be shadowing + -- x <- e1; x <- e2 + -- So we'll look up (Unqual x) twice, getting + -- the second binding both times, which is the + } -- one we want + + -- Typecheck the thing inside, passing on all + -- the Names bound, but separately; revert the envt + ; ((segs', thing), fvs) <- setLocalRdrEnv orig_lcl_env $ + go orig_lcl_env new_bndrs segs + + -- Figure out which of the bound names are used + ; let used_bndrs = filter (`elemNameSet` fvs) bndrs + ; return ((used_bndrs, segs', thing), fvs) } + + ; let seg' = (stmts', bndrs) + ; return (((seg':segs'), thing), + delListFromNameSet fvs bndrs) } + + par_ctxt = ParStmtCtxt ctxt + + cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 + dupErr vs = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:") + <+> quotes (ppr (head vs))) +\end{code} + + +%************************************************************************ +%* * +\subsubsection{mdo expressions} +%* * +%************************************************************************ + +\begin{code} +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] + + +---------------------------------------------------- +rnMDoStmts :: [LStmt RdrName] + -> RnM (thing, FreeVars) + -> RnM (([LStmt Name], thing), FreeVars) +rnMDoStmts stmts thing_inside + = -- Step1: bring all the binders of the mdo into scope + -- Remember that this also removes the binders from the + -- finally-returned free-vars + bindLocatedLocalsRn doc (collectLStmtsBinders stmts) $ \ bndrs -> + do { + -- Step 2: 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.) + segs <- rn_rec_stmts bndrs stmts + + ; (thing, fvs_later) <- thing_inside + + ; let + -- Step 3: 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 4: 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 segs_w_fwd_refs + + -- Step 5: 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 + (stmts', fvs) = segsToStmts grouped_segs fvs_later + + ; return ((stmts', thing), fvs) } + where + doc = text "In a recursive mdo-expression" + +--------------------------------------------- +rn_rec_stmts :: [Name] -> [LStmt RdrName] -> RnM [Segment (LStmt Name)] +rn_rec_stmts bndrs stmts = mappM (rn_rec_stmt bndrs) stmts `thenM` \ segs_s -> + returnM (concat segs_s) + +---------------------------------------------------- +rn_rec_stmt :: [Name] -> LStmt RdrName -> RnM [Segment (LStmt Name)] + -- 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 all_bndrs (L loc (ExprStmt expr _ _)) + = rnLExpr expr `thenM` \ (expr', fvs) -> + lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) -> + returnM [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, + L loc (ExprStmt expr' then_op placeHolderType))] + +rn_rec_stmt all_bndrs (L loc (BindStmt pat expr _ _)) + = rnLExpr expr `thenM` \ (expr', fv_expr) -> + rnLPat pat `thenM` \ (pat', fv_pat) -> + lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) -> + lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) -> + let + bndrs = mkNameSet (collectPatBinders pat') + fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 + in + returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs, + L loc (BindStmt pat' expr' bind_op fail_op))] + +rn_rec_stmt all_bndrs (L loc (LetStmt binds@(HsIPBinds _))) + = do { addErr (badIpBinds (ptext SLIT("an mdo expression")) binds) + ; failM } + +rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds))) + = rnValBinds (trimWith all_bndrs) binds `thenM` \ (binds', du_binds) -> + returnM [(duDefs du_binds, duUses du_binds, + emptyNameSet, L loc (LetStmt (HsValBinds binds')))] + +rn_rec_stmt all_bndrs (L loc (RecStmt stmts _ _ _ _)) -- Flatten Rec inside Rec + = rn_rec_stmts all_bndrs stmts + +rn_rec_stmt all_bndrs stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt" (ppr stmt) + +--------------------------------------------- +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 pairs + = fst (foldr mk_seg ([], emptyNameSet) pairs) + 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 `unionNameSets` defs + new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs) + -- Add the downstream fwd refs here + +---------------------------------------------------- +-- 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 togeher with the first two groups +-- { rec { x <- ...y...; p <- z ; y <- ...x... ; +-- q <- x ; z <- y } ; +-- r <- x } + +glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]] + +glomSegments [] = [] +glomSegments ((defs,uses,fwds,stmt) : segs) + -- Actually stmts will always be a singleton + = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others + where + segs' = glomSegments 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 :: [Segment [LStmt Name]] + -> FreeVars -- Free vars used 'later' + -> ([LStmt Name], FreeVars) + +segsToStmts [] fvs_later = ([], fvs_later) +segsToStmts ((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 segs fvs_later + new_stmt | non_rec = head ss + | otherwise = L (getLoc (head ss)) $ + RecStmt ss (nameSetToList used_later) (nameSetToList fwds) + [] emptyLHsBinds + where + non_rec = isSingleton ss && isEmptyNameSet fwds + used_later = defs `intersectNameSet` later_uses + -- The ones needed after the RecStmt +\end{code} + +%************************************************************************ +%* * +\subsubsection{breakpoint utils} +%* * +%************************************************************************ + +\begin{code} +#if defined(GHCI) && defined(BREAKPOINT) +mkBreakPointExpr :: [Name] -> RnM (HsExpr Name, FreeVars) +mkBreakPointExpr scope + = do sloc <- getSrcSpanM + undef <- lookupOccRn undefined_RDR + let inLoc = L sloc + lHsApp x y = inLoc (HsApp x y) + mkExpr fnName args = mkExpr' fnName (reverse args) + mkExpr' fnName [] = inLoc (HsVar fnName) + mkExpr' fnName (arg:args) + = lHsApp (mkExpr' fnName args) (inLoc arg) + expr = unLoc $ mkExpr breakpointJumpName [mkScopeArg scope, HsVar undef, HsLit msg] + mkScopeArg args + = unLoc $ mkExpr undef (map HsVar args) + msg = HsString (mkFastString (unpackFS (srcSpanFile sloc) ++ ":" ++ show (srcSpanStartLine sloc))) + return (expr, emptyFVs) +#endif +\end{code} + +%************************************************************************ +%* * +\subsubsection{Assertion utils} +%* * +%************************************************************************ + +\begin{code} +mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars) +-- Return an expression for (assertError "Foo.hs:27") +mkAssertErrorExpr + = getSrcSpanM `thenM` \ sloc -> + let + expr = HsApp (L sloc (HsVar assertErrorName)) (L sloc (HsLit msg)) + msg = HsStringPrim (mkFastString (showSDoc (ppr sloc))) + in + returnM (expr, emptyFVs) +\end{code} + +%************************************************************************ +%* * +\subsubsection{Errors} +%* * +%************************************************************************ + +\begin{code} +patSynErr e = do { addErr (sep [ptext SLIT("Pattern syntax in expression context:"), + nest 4 (ppr e)]) + ; return (EWildPat, emptyFVs) } + +parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts")) + +badIpBinds what binds + = hang (ptext SLIT("Implicit-parameter bindings illegal in") <+> what) + 2 (ppr binds) +\end{code} diff --git a/compiler/rename/RnExpr.lhs-boot b/compiler/rename/RnExpr.lhs-boot new file mode 100644 index 0000000000..b03f50a890 --- /dev/null +++ b/compiler/rename/RnExpr.lhs-boot @@ -0,0 +1,17 @@ +\begin{code}
+module RnExpr where
+import HsSyn
+import Name ( Name )
+import NameSet ( FreeVars )
+import RdrName ( RdrName )
+import TcRnTypes
+
+rnLExpr :: LHsExpr RdrName
+ -> RnM (LHsExpr Name, FreeVars)
+
+rnStmts :: forall thing.
+ HsStmtContext Name -> [LStmt RdrName]
+ -> RnM (thing, FreeVars)
+ -> RnM (([LStmt Name], thing), FreeVars)
+\end{code}
+
diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs new file mode 100644 index 0000000000..6752218b29 --- /dev/null +++ b/compiler/rename/RnHsSyn.lhs @@ -0,0 +1,156 @@ +% +% (c) The AQUA Project, Glasgow University, 1996-1998 +% +\section[RnHsSyn]{Specialisations of the @HsSyn@ syntax for the renamer} + +\begin{code} +module RnHsSyn( + -- Names + charTyCon_name, listTyCon_name, parrTyCon_name, tupleTyCon_name, + extractHsTyVars, extractHsTyNames, extractHsTyNames_s, + extractFunDepNames, extractHsCtxtTyNames, extractHsPredTyNames, + + -- Free variables + hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs, + + maybeGenericMatch + ) where + +#include "HsVersions.h" + +import HsSyn +import Class ( FunDep ) +import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon ) +import Name ( Name, getName, isTyVarName ) +import NameSet +import BasicTypes ( Boxity ) +import SrcLoc ( Located(..), unLoc ) +\end{code} + +%************************************************************************ +%* * +\subsection{Free variables} +%* * +%************************************************************************ + +These free-variable finders returns tycons and classes too. + +\begin{code} +charTyCon_name, listTyCon_name, parrTyCon_name :: Name +charTyCon_name = getName charTyCon +listTyCon_name = getName listTyCon +parrTyCon_name = getName parrTyCon + +tupleTyCon_name :: Boxity -> Int -> Name +tupleTyCon_name boxity n = getName (tupleTyCon boxity n) + +extractHsTyVars :: LHsType Name -> NameSet +extractHsTyVars x = filterNameSet isTyVarName (extractHsTyNames x) + +extractFunDepNames :: FunDep Name -> NameSet +extractFunDepNames (ns1, ns2) = mkNameSet ns1 `unionNameSets` mkNameSet ns2 + +extractHsTyNames :: LHsType Name -> NameSet +extractHsTyNames ty + = getl ty + where + getl (L _ ty) = get ty + + get (HsAppTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 + get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` getl ty + get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` getl ty + get (HsTupleTy con tys) = extractHsTyNames_s tys + get (HsFunTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 + get (HsPredTy p) = extractHsPredTyNames p + get (HsOpTy ty1 op ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op) + get (HsParTy ty) = getl ty + get (HsBangTy _ ty) = getl ty + get (HsNumTy n) = emptyNameSet + get (HsTyVar tv) = unitNameSet tv + get (HsSpliceTy _) = emptyNameSet -- Type splices mention no type variables + get (HsKindSig ty k) = getl ty + get (HsForAllTy _ tvs + ctxt ty) = (extractHsCtxtTyNames ctxt + `unionNameSets` getl ty) + `minusNameSet` + mkNameSet (hsLTyVarNames tvs) + +extractHsTyNames_s :: [LHsType Name] -> NameSet +extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys + +extractHsCtxtTyNames :: LHsContext Name -> NameSet +extractHsCtxtTyNames (L _ ctxt) + = foldr (unionNameSets . extractHsPredTyNames . unLoc) emptyNameSet ctxt + +-- You don't import or export implicit parameters, +-- so don't mention the IP names +extractHsPredTyNames (HsClassP cls tys) + = unitNameSet cls `unionNameSets` extractHsTyNames_s tys +extractHsPredTyNames (HsIParam n ty) + = extractHsTyNames ty +\end{code} + + +%************************************************************************ +%* * +\subsection{Free variables of declarations} +%* * +%************************************************************************ + +Return the Names that must be in scope if we are to use this declaration. +In all cases this is set up for interface-file declarations: + - for class decls we ignore the bindings + - for instance decls likewise, plus the pragmas + - for rule decls, we ignore HsRules + - for data decls, we ignore derivings + + *** See "THE NAMING STORY" in HsDecls **** + +\begin{code} +---------------- +hsSigsFVs :: [LSig Name] -> FreeVars +hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs) + +hsSigFVs (TypeSig v ty) = extractHsTyNames ty +hsSigFVs (SpecInstSig ty) = extractHsTyNames ty +hsSigFVs (SpecSig v ty inl) = extractHsTyNames ty +hsSigFVs other = emptyFVs + +---------------- +conDeclFVs (L _ (ConDecl { con_qvars = tyvars, con_cxt = context, + con_details = details, con_res = res_ty})) + = delFVs (map hsLTyVarName tyvars) $ + extractHsCtxtTyNames context `plusFV` + conDetailsFVs details `plusFV` + conResTyFVs res_ty + +conResTyFVs ResTyH98 = emptyFVs +conResTyFVs (ResTyGADT ty) = extractHsTyNames ty + +conDetailsFVs (PrefixCon btys) = plusFVs (map bangTyFVs btys) +conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2 +conDetailsFVs (RecCon flds) = plusFVs [bangTyFVs bty | (_, bty) <- flds] + +bangTyFVs bty = extractHsTyNames (getBangType bty) +\end{code} + + +%************************************************************************ +%* * +\subsection{A few functions on generic defintions +%* * +%************************************************************************ + +These functions on generics are defined over Matches Name, which is +why they are here and not in HsMatches. + +\begin{code} +maybeGenericMatch :: LMatch Name -> Maybe (HsType Name, LMatch Name) + -- Tells whether a Match is for a generic definition + -- and extract the type from a generic match and put it at the front + +maybeGenericMatch (L loc (Match (L _ (TypePat (L _ ty)) : pats) sig_ty grhss)) + = Just (ty, L loc (Match pats sig_ty grhss)) + +maybeGenericMatch other_match = Nothing +\end{code} diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs new file mode 100644 index 0000000000..654c101cd5 --- /dev/null +++ b/compiler/rename/RnNames.lhs @@ -0,0 +1,1138 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[RnNames]{Extracting imported and top-level names in scope} + +\begin{code} +module RnNames ( + rnImports, mkRdrEnvAndImports, importsFromLocalDecls, + rnExports, mkExportNameSet, + getLocalDeclBinders, extendRdrEnvRn, + reportUnusedNames, reportDeprecations + ) where + +#include "HsVersions.h" + +import DynFlags ( DynFlag(..), GhcMode(..) ) +import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl, + ForeignDecl(..), HsGroup(..), HsValBinds(..), + Sig(..), collectHsBindLocatedBinders, tyClDeclNames, + LIE ) +import RnEnv +import IfaceEnv ( ifaceExportNames ) +import LoadIface ( loadSrcInterface ) +import TcRnMonad hiding (LIE) + +import FiniteMap +import PrelNames ( pRELUDE, isUnboundName, main_RDR_Unqual ) +import Module ( Module, moduleString, unitModuleEnv, + lookupModuleEnv, moduleEnvElts, foldModuleEnv ) +import Name ( Name, nameSrcLoc, nameOccName, nameModule, isWiredInName, + nameParent, nameParent_maybe, isExternalName, + isBuiltInSyntax ) +import NameSet +import NameEnv +import OccName ( srcDataName, isTcOcc, pprNonVarNameSpace, + occNameSpace, + OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, + extendOccEnv ) +import HscTypes ( GenAvailInfo(..), AvailInfo, + HomePackageTable, PackageIfaceTable, + unQualInScope, + Deprecs(..), ModIface(..), Dependencies(..), + lookupIface, ExternalPackageState(..) + ) +import Packages ( PackageIdH(..) ) +import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, + GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), + emptyGlobalRdrEnv, plusGlobalRdrEnv, globalRdrEnvElts, + extendGlobalRdrEnv, lookupGlobalRdrEnv, unQualOK, lookupGRE_Name, + Provenance(..), ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), + importSpecLoc, importSpecModule, isLocalGRE, pprNameProvenance ) +import Outputable +import Maybes ( isNothing, catMaybes, mapCatMaybes, seqMaybe, orElse ) +import SrcLoc ( Located(..), mkGeneralSrcSpan, + unLoc, noLoc, srcLocSpan, SrcSpan ) +import BasicTypes ( DeprecTxt ) +import DriverPhases ( isHsBoot ) +import Util ( notNull ) +import List ( partition ) +import IO ( openFile, IOMode(..) ) +\end{code} + + + +%************************************************************************ +%* * + rnImports +%* * +%************************************************************************ + +\begin{code} +rnImports :: [LImportDecl RdrName] -> RnM [LImportDecl Name] +rnImports imports + -- PROCESS IMPORT DECLS + -- Do the non {- SOURCE -} ones first, so that we get a helpful + -- warning for {- SOURCE -} ones that are unnecessary + = do this_mod <- getModule + implicit_prelude <- doptM Opt_ImplicitPrelude + let all_imports = mk_prel_imports this_mod implicit_prelude ++ imports + (source, ordinary) = partition is_source_import all_imports + is_source_import (L _ (ImportDecl _ is_boot _ _ _)) = is_boot + get_imports = rnImportDecl this_mod + + stuff1 <- mapM get_imports ordinary + stuff2 <- mapM get_imports source + return (stuff1 ++ stuff2) + where +-- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); +-- because the former doesn't even look at Prelude.hi for instance +-- declarations, whereas the latter does. + mk_prel_imports this_mod implicit_prelude + | this_mod == pRELUDE + || explicit_prelude_import + || not implicit_prelude + = [] + | otherwise = [preludeImportDecl] + explicit_prelude_import + = notNull [ () | L _ (ImportDecl mod _ _ _ _) <- imports, + unLoc mod == pRELUDE ] + +preludeImportDecl :: LImportDecl RdrName +preludeImportDecl + = L loc $ + ImportDecl (L loc pRELUDE) + False {- Not a boot interface -} + False {- Not qualified -} + Nothing {- No "as" -} + Nothing {- No import list -} + where + loc = mkGeneralSrcSpan FSLIT("Implicit import declaration") + +mkRdrEnvAndImports :: [LImportDecl Name] -> RnM (GlobalRdrEnv, ImportAvails) +mkRdrEnvAndImports imports + = do this_mod <- getModule + let get_imports = importsFromImportDecl this_mod + stuff <- mapM get_imports imports + let (imp_gbl_envs, imp_avails) = unzip stuff + gbl_env :: GlobalRdrEnv + gbl_env = foldr plusGlobalRdrEnv emptyGlobalRdrEnv imp_gbl_envs + + all_avails :: ImportAvails + all_avails = foldr plusImportAvails emptyImportAvails imp_avails + -- ALL DONE + return (gbl_env, all_avails) + +\end{code} + +\begin{code} +rnImportDecl :: Module + -> LImportDecl RdrName + -> RnM (LImportDecl Name) +rnImportDecl this_mod (L loc importDecl@(ImportDecl loc_imp_mod_name want_boot qual_only as_mod imp_details)) + = setSrcSpan loc $ + do iface <- loadSrcInterface doc imp_mod_name want_boot + let qual_mod_name = case as_mod of + Nothing -> imp_mod_name + Just another_name -> another_name + imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, + is_dloc = loc, is_as = qual_mod_name } + total_avails <- ifaceExportNames (mi_exports iface) + importDecl' <- rnImportDecl' iface imp_spec importDecl total_avails + return (L loc importDecl') + where imp_mod_name = unLoc loc_imp_mod_name + doc = ppr imp_mod_name <+> ptext SLIT("is directly imported") + +rnImportDecl' :: ModIface -> ImpDeclSpec -> ImportDecl RdrName -> NameSet -> RnM (ImportDecl Name) +rnImportDecl' iface decl_spec (ImportDecl mod_name want_boot qual_only as_mod Nothing) all_names + = return $ ImportDecl mod_name want_boot qual_only as_mod Nothing +rnImportDecl' iface decl_spec (ImportDecl mod_name want_boot qual_only as_mod (Just (want_hiding,import_items))) all_names + = do import_items_mbs <- mapM (srcSpanWrapper) import_items + let rn_import_items = concat . catMaybes $ import_items_mbs + return $ ImportDecl mod_name want_boot qual_only as_mod (Just (want_hiding,rn_import_items)) + where + srcSpanWrapper (L span ieRdr) + = setSrcSpan span $ + case get_item ieRdr of + Nothing + -> do addErr (badImportItemErr iface decl_spec ieRdr) + return Nothing + Just ieNames + -> return (Just [L span ie | ie <- ieNames]) + occ_env :: OccEnv Name -- Maps OccName to corresponding Name + occ_env = mkOccEnv [(nameOccName n, n) | n <- nameSetToList all_names] + -- This env will have entries for data constructors too, + -- they won't make any difference because naked entities like T + -- in an import list map to TcOccs, not VarOccs. + + sub_env :: NameEnv [Name] + sub_env = mkSubNameEnv all_names + + get_item :: IE RdrName -> Maybe [IE Name] + -- Empty result for a bad item. + -- Singleton result is typical case. + -- Can have two when we are hiding, and mention C which might be + -- both a class and a data constructor. + get_item item@(IEModuleContents _) + = Nothing + get_item (IEThingAll tc) + = do name <- check_name tc + return [IEThingAll name] + get_item (IEThingAbs tc) + | want_hiding -- hiding ( C ) + -- Here the 'C' can be a data constructor + -- *or* a type/class, or even both + = case catMaybes [check_name tc, check_name (setRdrNameSpace tc srcDataName)] of + [] -> Nothing + names -> return [ IEThingAbs n | n <- names ] + | otherwise + = do name <- check_name tc + return [IEThingAbs name] + get_item (IEThingWith n ns) -- import (C (A,B)) + = do name <- check_name n + let env = mkOccEnv [(nameOccName s, s) | s <- subNames sub_env name] + mb_names = map (lookupOccEnv env . rdrNameOcc) ns + names <- sequence mb_names + return [IEThingWith name names] + get_item (IEVar n) + = do name <- check_name n + return [IEVar name] + + check_name :: RdrName -> Maybe Name + check_name rdrName + = lookupOccEnv occ_env (rdrNameOcc rdrName) + + +importsFromImportDecl :: Module + -> LImportDecl Name + -> RnM (GlobalRdrEnv, ImportAvails) + +importsFromImportDecl this_mod + (L loc (ImportDecl loc_imp_mod_name want_boot qual_only as_mod imp_details)) + = + setSrcSpan loc $ + + -- 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 <+> ptext SLIT("is directly imported") + in + loadSrcInterface doc imp_mod_name want_boot `thenM` \ iface -> + + -- 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 ) + + -- 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 + warnIf (want_boot && not (mi_boot iface)) + (warnRedundantSourceImport imp_mod_name) `thenM_` + + let + imp_mod = mi_module iface + deprecs = mi_deprecs iface + is_orph = mi_orphan iface + deps = mi_deps iface + + filtered_exports = filter not_this_mod (mi_exports iface) + not_this_mod (mod,_) = mod /= this_mod + -- 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.) + -- + -- Tiresome consequence: if you say + -- module A where + -- import B( AType ) + -- type AType = ... + -- + -- module B( AType ) where + -- import {-# SOURCE #-} A( AType ) + -- + -- then you'll get a 'B does not export AType' message. Oh well. + + qual_mod_name = case as_mod of + Nothing -> imp_mod_name + Just another_name -> another_name + imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, + is_dloc = loc, is_as = qual_mod_name } + in + -- Get the total imports, and filter them according to the import list + ifaceExportNames filtered_exports `thenM` \ total_avails -> + filterImports iface imp_spec + imp_details total_avails `thenM` \ (avail_env, gbl_env) -> + + getDOpts `thenM` \ dflags -> + + let + -- Compute new transitive dependencies + + orphans | is_orph = ASSERT( not (imp_mod_name `elem` dep_orphs deps) ) + imp_mod_name : dep_orphs deps + | otherwise = dep_orphs deps + + (dependent_mods, dependent_pkgs) + = case mi_package iface of + HomePackage -> + -- 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 LoadIface.loadHiBootInterface + ((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps) + + ExtPackage pkg -> + -- Imported module is from another package + -- Dump the dependent modules + -- Add the package imp_mod comes from to the dependent packages + ASSERT2( not (pkg `elem` dep_pkgs deps), ppr pkg <+> ppr (dep_pkgs deps) ) + ([], pkg : dep_pkgs deps) + + -- True <=> import M () + import_all = case imp_details of + Just (is_hiding, ls) -> not is_hiding && null ls + other -> False + + -- unqual_avails is the Avails that are visible in *unqualified* form + -- We need to know this so we know what to export when we see + -- module M ( module P ) where ... + -- Then we must export whatever came from P unqualified. + imports = ImportAvails { + imp_env = unitModuleEnv qual_mod_name avail_env, + imp_mods = unitModuleEnv imp_mod (imp_mod, import_all, loc), + imp_orphs = orphans, + imp_dep_mods = mkModDeps dependent_mods, + imp_dep_pkgs = dependent_pkgs } + + in + -- Complain if we import a deprecated module + ifOptM Opt_WarnDeprecations ( + case deprecs of + DeprecAll txt -> addWarn (moduleDeprec imp_mod_name txt) + other -> returnM () + ) `thenM_` + + returnM (gbl_env, imports) + +warnRedundantSourceImport mod_name + = ptext SLIT("Unnecessary {- SOURCE -} in the import of module") + <+> quotes (ppr mod_name) +\end{code} + + +%************************************************************************ +%* * + importsFromLocalDecls +%* * +%************************************************************************ + +From the top-level declarations of this module produce + * the lexical environment + * the ImportAvails +created by its bindings. + +Complain about duplicate bindings + +\begin{code} +importsFromLocalDecls :: HsGroup RdrName -> RnM TcGblEnv +importsFromLocalDecls group + = do { gbl_env <- getGblEnv + + ; names <- getLocalDeclBinders gbl_env group + + ; implicit_prelude <- doptM Opt_ImplicitPrelude + ; let { + -- Optimisation: filter out names for built-in syntax + -- They just clutter up the environment (esp tuples), and the parser + -- will generate Exact RdrNames for them, so the cluttered + -- envt is no use. To avoid doing this filter all the time, + -- we use -fno-implicit-prelude as a clue that the filter is + -- worth while. Really, it's only useful for GHC.Base and GHC.Tuple. + -- + -- It's worth doing because it makes the environment smaller for + -- every module that imports the Prelude + -- + -- Note: don't filter the gbl_env (hence all_names, not filered_all_names + -- in defn of gres above). Stupid reason: when parsing + -- data type decls, the constructors start as Exact tycon-names, + -- and then get turned into data con names by zapping the name space; + -- but that stops them being Exact, so they get looked up. + -- Ditto in fixity decls; e.g. infix 5 : + -- Sigh. It doesn't matter because it only affects the Data.Tuple really. + -- The important thing is to trim down the exports. + filtered_names + | implicit_prelude = names + | otherwise = filter (not . isBuiltInSyntax) names ; + + ; this_mod = tcg_mod gbl_env + ; imports = emptyImportAvails { + imp_env = unitModuleEnv this_mod $ + mkNameSet filtered_names + } + } + + ; rdr_env' <- extendRdrEnvRn (tcg_rdr_env gbl_env) names + + ; returnM (gbl_env { tcg_rdr_env = rdr_env', + tcg_imports = imports `plusImportAvails` tcg_imports gbl_env }) + } + +extendRdrEnvRn :: GlobalRdrEnv -> [Name] -> RnM GlobalRdrEnv +-- Add the new locally-bound names one by one, checking for duplicates as +-- we do so. Remember that in Template Haskell the duplicates +-- might *already be* in the GlobalRdrEnv from higher up the module +extendRdrEnvRn rdr_env names + = foldlM add_local rdr_env names + where + add_local rdr_env name + | gres <- lookupGlobalRdrEnv rdr_env (nameOccName name) + , (dup_gre:_) <- filter isLocalGRE gres -- Check for existing *local* defns + = do { addDupDeclErr (gre_name dup_gre) name + ; return rdr_env } + | otherwise + = return (extendGlobalRdrEnv rdr_env new_gre) + where + new_gre = GRE {gre_name = name, gre_prov = LocalDef} +\end{code} + +@getLocalDeclBinders@ returns the names for an @HsDecl@. It's +used for source code. + + *** See "THE NAMING STORY" in HsDecls **** + +\begin{code} +getLocalDeclBinders :: TcGblEnv -> HsGroup RdrName -> RnM [Name] +getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, + hs_tyclds = tycl_decls, + hs_fords = foreign_decls }) + = do { tc_names_s <- mappM new_tc tycl_decls + ; val_names <- mappM new_simple val_bndrs + ; return (foldr (++) val_names tc_names_s) } + where + mod = tcg_mod gbl_env + is_hs_boot = isHsBoot (tcg_src gbl_env) ; + val_bndrs | is_hs_boot = sig_hs_bndrs + | otherwise = for_hs_bndrs ++ val_hs_bndrs + -- In a hs-boot file, the value binders come from the + -- *signatures*, and there should be no foreign binders + + new_simple rdr_name = newTopSrcBinder mod Nothing rdr_name + + sig_hs_bndrs = [nm | L _ (TypeSig nm _) <- val_sigs] + val_hs_bndrs = collectHsBindLocatedBinders val_decls + for_hs_bndrs = [nm | L _ (ForeignImport nm _ _ _) <- foreign_decls] + + new_tc tc_decl + = do { main_name <- newTopSrcBinder mod Nothing main_rdr + ; sub_names <- mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs + ; return (main_name : sub_names) } + where + (main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl) +\end{code} + + +%************************************************************************ +%* * +\subsection{Filtering imports} +%* * +%************************************************************************ + +@filterImports@ takes the @ExportEnv@ telling what the imported module makes +available, and filters it through the import spec (if any). + +\begin{code} +filterImports :: ModIface + -> ImpDeclSpec -- The span for the entire import decl + -> Maybe (Bool, [LIE Name]) -- Import spec; True => hiding + -> NameSet -- What's available + -> RnM (NameSet, -- What's imported (qualified or unqualified) + GlobalRdrEnv) -- Same again, but in GRE form + + -- Complains if import spec mentions things that the module doesn't export + -- Warns/informs if import spec contains duplicates. + +mkGenericRdrEnv decl_spec names + = mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = Imported [imp_spec] } + | name <- nameSetToList names ] + where + imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } + +filterImports iface decl_spec Nothing all_names + = return (all_names, mkGenericRdrEnv decl_spec all_names) + +filterImports iface decl_spec (Just (want_hiding, import_items)) all_names + = mapM (addLocM get_item) import_items >>= \gres_s -> + let gres = concat gres_s + specified_names = mkNameSet (map gre_name gres) + in if not want_hiding then + return (specified_names, mkGlobalRdrEnv gres) + else let keep n = not (n `elemNameSet` specified_names) + pruned_avails = filterNameSet keep all_names + in return (pruned_avails, mkGenericRdrEnv decl_spec pruned_avails) + where + sub_env :: NameEnv [Name] -- Classify each name by its parent + sub_env = mkSubNameEnv all_names + + succeed_with :: Bool -> [Name] -> RnM [GlobalRdrElt] + succeed_with all_explicit names + = do { loc <- getSrcSpanM + ; returnM (map (mk_gre loc) names) } + where + mk_gre loc name = GRE { gre_name = name, + gre_prov = Imported [imp_spec] } + where + imp_spec = ImpSpec { is_decl = decl_spec, is_item = item_spec } + item_spec = ImpSome { is_explicit = explicit, is_iloc = loc } + explicit = all_explicit || isNothing (nameParent_maybe name) + + get_item :: IE Name -> RnM [GlobalRdrElt] + -- Empty result for a bad item. + -- Singleton result is typical case. + -- Can have two when we are hiding, and mention C which might be + -- both a class and a data constructor. + get_item item@(IEModuleContents _) + -- This case should be filtered out by 'rnImports'. + = panic "filterImports: IEModuleContents?" + + get_item (IEThingAll name) + = case subNames sub_env name of + [] -> -- This occurs when you import T(..), but + -- only export T abstractly. + do ifOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn name)) + succeed_with False [name] + names -> succeed_with False (name:names) + + get_item (IEThingAbs name) + = succeed_with True [name] + + get_item (IEThingWith name names) + = succeed_with True (name:names) + get_item (IEVar name) + = succeed_with True [name] + +\end{code} + + +%************************************************************************ +%* * +\subsection{Export list processing} +%* * +%************************************************************************ + +Processing the export list. + +You might think that we should record things that appear in the export +list as ``occurrences'' (using @addOccurrenceName@), but you'd be +wrong. We do check (here) that they are in scope, but there is no +need to slurp in their actual declaration (which is what +@addOccurrenceName@ forces). + +Indeed, doing so would big trouble when compiling @PrelBase@, because +it re-exports @GHC@, which includes @takeMVar#@, whose type includes +@ConcBase.StateAndSynchVar#@, and so on... + +\begin{code} +type ExportAccum -- The type of the accumulating parameter of + -- the main worker function in rnExports + = ([Module], -- 'module M's seen so far + ExportOccMap, -- Tracks exported occurrence names + NameSet) -- The accumulated exported stuff +emptyExportAccum = ([], emptyOccEnv, emptyNameSet) + +type ExportOccMap = OccEnv (Name, IE RdrName) + -- Tracks what a particular exported OccName + -- in an export list refers to, and which item + -- it came from. It's illegal to export two distinct things + -- that have the same occurrence name + +rnExports :: Maybe [LIE RdrName] + -> RnM (Maybe [LIE Name]) +rnExports Nothing = return Nothing +rnExports (Just exports) + = do TcGblEnv { tcg_imports = ImportAvails { imp_env = imp_env } } <- getGblEnv + let sub_env :: NameEnv [Name] -- Classify each name by its parent + sub_env = mkSubNameEnv (foldModuleEnv unionNameSets emptyNameSet imp_env) + rnExport (IEVar rdrName) + = do name <- lookupGlobalOccRn rdrName + return (IEVar name) + rnExport (IEThingAbs rdrName) + = do name <- lookupGlobalOccRn rdrName + return (IEThingAbs name) + rnExport (IEThingAll rdrName) + = do name <- lookupGlobalOccRn rdrName + return (IEThingAll name) + rnExport ie@(IEThingWith rdrName rdrNames) + = do name <- lookupGlobalOccRn rdrName + if isUnboundName name + then return (IEThingWith name []) + else do + let env = mkOccEnv [(nameOccName s, s) | s <- subNames sub_env name] + mb_names = map (lookupOccEnv env . rdrNameOcc) rdrNames + if any isNothing mb_names + then do addErr (exportItemErr ie) + return (IEThingWith name []) + else return (IEThingWith name (catMaybes mb_names)) + rnExport (IEModuleContents mod) + = return (IEModuleContents mod) + rn_exports <- mapM (wrapLocM rnExport) exports + return (Just rn_exports) + +mkExportNameSet :: Bool -- False => no 'module M(..) where' header at all + -> Maybe ([LIE Name], [LIE RdrName]) -- Nothing => no explicit export list + -> RnM NameSet + -- Complains if two distinct exports have same OccName + -- Warns about identical exports. + -- Complains about exports items not in scope + +mkExportNameSet explicit_mod exports + = do TcGblEnv { tcg_rdr_env = rdr_env, + tcg_imports = imports } <- getGblEnv + + -- If the module header is omitted altogether, then behave + -- as if the user had written "module Main(main) where..." + -- EXCEPT in interactive mode, when we behave as if he had + -- written "module Main where ..." + -- Reason: don't want to complain about 'main' not in scope + -- in interactive mode + ghc_mode <- getGhcMode + real_exports <- case () of + () | explicit_mod + -> return exports + | ghc_mode == Interactive + -> return Nothing + | otherwise + -> do mainName <- lookupGlobalOccRn main_RDR_Unqual + return (Just ([noLoc (IEVar mainName)] + ,[noLoc (IEVar main_RDR_Unqual)])) + -- ToDo: the 'noLoc' here is unhelpful if 'main' turns out to be out of scope + exports_from_avail real_exports rdr_env imports + + +exports_from_avail Nothing rdr_env imports + = -- Export all locally-defined things + -- We do this by filtering the global RdrEnv, + -- keeping only things that are locally-defined + return (mkNameSet [ gre_name gre + | gre <- globalRdrEnvElts rdr_env, + isLocalGRE gre ]) + +exports_from_avail (Just (items,origItems)) rdr_env (ImportAvails { imp_env = imp_env }) + = do (_, _, exports) <- foldlM do_litem emptyExportAccum (zip items origItems) + return exports + where + sub_env :: NameEnv [Name] -- Classify each name by its parent + sub_env = mkSubNameEnv (foldModuleEnv unionNameSets emptyNameSet imp_env) + + do_litem :: ExportAccum -> (LIE Name, LIE RdrName) -> RnM ExportAccum + do_litem acc (ieName, ieRdr) + = addLocM (exports_from_item acc (unLoc ieRdr)) ieName + + exports_from_item :: ExportAccum -> IE RdrName -> IE Name -> RnM ExportAccum + exports_from_item acc@(mods, occs, exports) ieRdr@(IEModuleContents mod) ie + | mod `elem` mods -- Duplicate export of M + = do { warn_dup_exports <- doptM Opt_WarnDuplicateExports ; + warnIf warn_dup_exports (dupModuleExport mod) ; + returnM acc } + + | otherwise + = case lookupModuleEnv imp_env mod of + Nothing -> do addErr (modExportErr mod) + return acc + Just names + -> do let new_exports = filterNameSet (inScopeUnqual rdr_env) names + -- This check_occs not only finds conflicts between this item + -- and others, but also internally within this item. That is, + -- if 'M.x' is in scope in several ways, we'll have several + -- members of mod_avails with the same OccName. + occs' <- check_occs ieRdr occs (nameSetToList new_exports) + return (mod:mods, occs', exports `unionNameSets` new_exports) + + exports_from_item acc@(mods, occs, exports) ieRdr ie + = if isUnboundName (ieName ie) + then return acc -- Avoid error cascade + else let new_exports = filterAvail ie sub_env in + do -- checkErr (not (null (drop 1 new_exports))) (exportItemErr ie) + checkForDodgyExport ie new_exports + occs' <- check_occs ieRdr occs new_exports + return (mods, occs', addListToNameSet exports new_exports) + +------------------------------- +filterAvail :: IE Name -- Wanted + -> NameEnv [Name] -- Maps type/class names to their sub-names + -> [Name] + +filterAvail (IEVar n) subs = [n] +filterAvail (IEThingAbs n) subs = [n] +filterAvail (IEThingAll n) subs = n : subNames subs n +filterAvail (IEThingWith n ns) subs = n : ns +filterAvail (IEModuleContents _) _ = panic "filterAvail" + +subNames :: NameEnv [Name] -> Name -> [Name] +subNames env n = lookupNameEnv env n `orElse` [] + +mkSubNameEnv :: NameSet -> NameEnv [Name] +-- Maps types and classes to their constructors/classops respectively +-- This mapping just makes it easier to deal with A(..) export items +mkSubNameEnv names + = foldNameSet add_name emptyNameEnv names + where + add_name name env + | Just parent <- nameParent_maybe name + = extendNameEnv_C (\ns _ -> name:ns) env parent [name] + | otherwise = env + +------------------------------- +inScopeUnqual :: GlobalRdrEnv -> Name -> Bool +-- Checks whether the Name is in scope unqualified, +-- regardless of whether it's ambiguous or not +inScopeUnqual env n = any unQualOK (lookupGRE_Name env n) + +------------------------------- +checkForDodgyExport :: IE Name -> [Name] -> RnM () +checkForDodgyExport ie@(IEThingAll tc) [n] + | isTcOcc (nameOccName n) = addWarn (dodgyExportWarn tc) + -- This occurs when you export T(..), but + -- only import T abstractly, or T is a synonym. + -- The single [n] is the type or class itself + | otherwise = addErr (exportItemErr ie) + -- This happes if you export x(..), which is bogus +checkForDodgyExport _ _ = return () + +------------------------------- +check_occs :: IE RdrName -> ExportOccMap -> [Name] -> RnM ExportOccMap +check_occs ie occs names + = foldlM check occs names + where + check occs name + = case lookupOccEnv occs name_occ of + Nothing -> returnM (extendOccEnv occs name_occ (name, ie)) + + Just (name', ie') + | name == name' -- Duplicate export + -> do { warn_dup_exports <- doptM Opt_WarnDuplicateExports ; + warnIf warn_dup_exports (dupExportWarn name_occ ie ie') ; + returnM occs } + + | otherwise -- Same occ name but different names: an error + -> do { global_env <- getGlobalRdrEnv ; + addErr (exportClashErr global_env name name' ie ie') ; + returnM occs } + where + name_occ = nameOccName name +\end{code} + +%********************************************************* +%* * + Deprecations +%* * +%********************************************************* + +\begin{code} +reportDeprecations :: TcGblEnv -> RnM () +reportDeprecations tcg_env + = ifOptM Opt_WarnDeprecations $ + do { (eps,hpt) <- getEpsAndHpt + -- By this time, typechecking is complete, + -- so the PIT is fully populated + ; mapM_ (check hpt (eps_PIT eps)) all_gres } + where + used_names = allUses (tcg_dus tcg_env) + -- Report on all deprecated uses; hence allUses + all_gres = globalRdrEnvElts (tcg_rdr_env tcg_env) + + check hpt pit (GRE {gre_name = name, gre_prov = Imported (imp_spec:_)}) + | name `elemNameSet` used_names + , Just deprec_txt <- lookupDeprec hpt pit name + = setSrcSpan (importSpecLoc imp_spec) $ + addWarn (sep [ptext SLIT("Deprecated use of") <+> + pprNonVarNameSpace (occNameSpace (nameOccName name)) <+> + quotes (ppr name), + (parens imp_msg) <> colon, + (ppr deprec_txt) ]) + where + name_mod = nameModule name + imp_mod = importSpecModule imp_spec + imp_msg = ptext SLIT("imported from") <+> ppr imp_mod <> extra + extra | imp_mod == name_mod = empty + | otherwise = ptext SLIT(", but defined in") <+> ppr name_mod + + check hpt pit ok_gre = returnM () -- Local, or not used, or not deprectated + -- The Imported pattern-match: don't deprecate 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 + +lookupDeprec :: HomePackageTable -> PackageIfaceTable + -> Name -> Maybe DeprecTxt +lookupDeprec hpt pit n + = case lookupIface hpt pit (nameModule n) of + Just iface -> mi_dep_fn iface n `seqMaybe` -- Bleat if the thing, *or + mi_dep_fn iface (nameParent n) -- its parent*, is deprec'd + Nothing + | isWiredInName n -> Nothing + -- We have not necessarily loaded the .hi file for a + -- wired-in name (yet), although we *could*. + -- And we never deprecate them + + | otherwise -> pprPanic "lookupDeprec" (ppr n) + -- By now all the interfaces should have been loaded + +gre_is_used :: NameSet -> GlobalRdrElt -> Bool +gre_is_used used_names gre = gre_name gre `elemNameSet` used_names +\end{code} + +%********************************************************* +%* * + Unused names +%* * +%********************************************************* + +\begin{code} +reportUnusedNames :: Maybe [LIE RdrName] -- Export list + -> TcGblEnv -> RnM () +reportUnusedNames export_decls gbl_env + = do { traceRn ((text "RUN") <+> (ppr (tcg_dus gbl_env))) + ; warnUnusedTopBinds unused_locals + ; warnUnusedModules unused_imp_mods + ; warnUnusedImports unused_imports + ; warnDuplicateImports defined_and_used + ; printMinimalImports minimal_imports } + where + used_names, all_used_names :: NameSet + used_names = findUses (tcg_dus gbl_env) emptyNameSet + -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used + -- Hence findUses + + all_used_names = used_names `unionNameSets` + mkNameSet (mapCatMaybes nameParent_maybe (nameSetToList used_names)) + -- A use of C implies a use of T, + -- if C was brought into scope by T(..) or T(C) + + -- Collect the defined names from the in-scope environment + defined_names :: [GlobalRdrElt] + defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env) + + -- Note that defined_and_used, defined_but_not_used + -- are both [GRE]; that's why we need defined_and_used + -- rather than just all_used_names + defined_and_used, defined_but_not_used :: [GlobalRdrElt] + (defined_and_used, defined_but_not_used) + = partition (gre_is_used all_used_names) defined_names + + -- 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 :: [GlobalRdrElt] + unused_locals = filter is_unused_local defined_but_not_used + is_unused_local :: GlobalRdrElt -> Bool + is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre) + + unused_imports :: [GlobalRdrElt] + unused_imports = filter unused_imp defined_but_not_used + unused_imp (GRE {gre_prov = Imported imp_specs}) + = not (all (module_unused . importSpecModule) imp_specs) + && or [exp | ImpSpec { is_item = ImpSome { is_explicit = exp } } <- imp_specs] + -- Don't complain about unused imports if we've already said the + -- entire import is unused + unused_imp other = False + + -- To figure out the minimal set of imports, start with the things + -- that are in scope (i.e. in gbl_env). Then just combine them + -- into a bunch of avails, so they are properly grouped + -- + -- BUG WARNING: this does not deal properly with qualified imports! + minimal_imports :: FiniteMap Module AvailEnv + minimal_imports0 = foldr add_expall emptyFM expall_mods + minimal_imports1 = foldr add_name minimal_imports0 defined_and_used + minimal_imports = foldr add_inst_mod minimal_imports1 direct_import_mods + -- The last line makes sure that we retain all direct imports + -- even if we import nothing explicitly. + -- It's not necessarily redundant to import such modules. Consider + -- module This + -- import M () + -- + -- The import M() is not *necessarily* redundant, even if + -- we suck in no instance decls from M (e.g. it contains + -- no instance decls, or This contains no code). It may be + -- that we import M solely to ensure that M's orphan instance + -- decls (or those in its imports) are visible to people who + -- import This. Sigh. + -- There's really no good way to detect this, so the error message + -- in RnEnv.warnUnusedModules is weakened instead + + -- We've carefully preserved the provenance so that we can + -- construct minimal imports that import the name by (one of) + -- the same route(s) as the programmer originally did. + add_name (GRE {gre_name = n, gre_prov = Imported imp_specs}) acc + = addToFM_C plusAvailEnv acc (importSpecModule (head imp_specs)) + (unitAvailEnv (mk_avail n (nameParent_maybe n))) + add_name other acc + = acc + + -- Modules mentioned as 'module M' in the export list + expall_mods = case export_decls of + Nothing -> [] + Just es -> [m | L _ (IEModuleContents m) <- es] + + -- This is really bogus. The idea is that if we see 'module M' in + -- the export list we must retain the import decls that drive it + -- If we aren't careful we might see + -- module A( module M ) where + -- import M + -- import N + -- and suppose that N exports everything that M does. Then we + -- must not drop the import of M even though N brings it all into + -- scope. + -- + -- BUG WARNING: 'module M' exports aside, what if M.x is mentioned?! + -- + -- The reason that add_expall is bogus is that it doesn't take + -- qualified imports into account. But it's an improvement. + add_expall mod acc = addToFM_C plusAvailEnv acc mod emptyAvailEnv + + -- n is the name of the thing, p is the name of its parent + mk_avail n (Just p) = AvailTC p [p,n] + mk_avail n Nothing | isTcOcc (nameOccName n) = AvailTC n [n] + | otherwise = Avail n + + add_inst_mod (mod,_,_) acc + | mod `elemFM` acc = acc -- We import something already + | otherwise = addToFM acc mod emptyAvailEnv + where + -- Add an empty collection of imports for a module + -- from which we have sucked only instance decls + + imports = tcg_imports gbl_env + + direct_import_mods :: [(Module, Bool, SrcSpan)] + -- See the type of the imp_mods for this triple + direct_import_mods = moduleEnvElts (imp_mods imports) + + -- unused_imp_mods are the directly-imported modules + -- that are not mentioned in minimal_imports1 + -- [Note: not 'minimal_imports', because that includes directly-imported + -- modules even if we use nothing from them; see notes above] + -- + -- BUG WARNING: does not deal correctly with multiple imports of the same module + -- becuase direct_import_mods has only one entry per module + unused_imp_mods = [(mod,loc) | (mod,no_imp,loc) <- direct_import_mods, + not (mod `elemFM` minimal_imports1), + mod /= pRELUDE, + not no_imp] + -- The not no_imp part is not to complain about + -- import M (), which is an idiom for importing + -- instance declarations + + module_unused :: Module -> Bool + module_unused mod = any (((==) mod) . fst) unused_imp_mods + +--------------------- +warnDuplicateImports :: [GlobalRdrElt] -> RnM () +-- Given the GREs for names that are used, figure out which imports +-- could be omitted without changing the top-level environment. +-- +-- NB: Given import Foo( T ) +-- import qualified Foo +-- we do not report a duplicate import, even though Foo.T is brought +-- into scope by both, because there's nothing you can *omit* without +-- changing the top-level environment. So we complain only if it's +-- explicitly named in both imports or neither. +-- +-- Furthermore, we complain about Foo.T only if +-- there is no complaint about (unqualified) T + +warnDuplicateImports gres + = ifOptM Opt_WarnUnusedImports $ + sequenceM_ [ warn name pr + -- The 'head' picks the first offending group + -- for this particular name + | GRE { gre_name = name, gre_prov = Imported imps } <- gres + , pr <- redundants imps ] + where + warn name (red_imp, cov_imp) + = addWarnAt (importSpecLoc red_imp) + (vcat [ptext SLIT("Redundant import of:") <+> quotes pp_name, + ptext SLIT("It is also") <+> ppr cov_imp]) + where + pp_name | is_qual red_decl = ppr (is_as red_decl) <> dot <> ppr occ + | otherwise = ppr occ + occ = nameOccName name + red_decl = is_decl red_imp + + redundants :: [ImportSpec] -> [(ImportSpec,ImportSpec)] + -- The returned pair is (redundant-import, covering-import) + redundants imps + = [ (red_imp, cov_imp) + | red_imp <- imps + , cov_imp <- take 1 (filter (covers red_imp) imps) ] + + -- "red_imp" is a putative redundant import + -- "cov_imp" potentially covers it + -- This test decides whether red_imp could be dropped + -- + -- NOTE: currently the test does not warn about + -- import M( x ) + -- imoprt N( x ) + -- even if the same underlying 'x' is involved, because dropping + -- either import would change the qualified names in scope (M.x, N.x) + -- But if the qualified names aren't used, the import is indeed redundant + -- Sadly we don't know that. Oh well. + covers red_imp@(ImpSpec { is_decl = red_decl, is_item = red_item }) + cov_imp@(ImpSpec { is_decl = cov_decl, is_item = cov_item }) + | red_loc == cov_loc + = False -- Ignore diagonal elements + | not (is_as red_decl == is_as cov_decl) + = False -- They bring into scope different qualified names + | not (is_qual red_decl) && is_qual cov_decl + = False -- Covering one doesn't bring unqualified name into scope + | red_selective + = not cov_selective -- Redundant one is selective and covering one isn't + || red_later -- Both are explicit; tie-break using red_later + | otherwise + = not cov_selective -- Neither import is selective + && (is_mod red_decl == is_mod cov_decl) -- They import the same module + && red_later -- Tie-break + where + red_loc = importSpecLoc red_imp + cov_loc = importSpecLoc cov_imp + red_later = red_loc > cov_loc + cov_selective = selectiveImpItem cov_item + red_selective = selectiveImpItem red_item + +selectiveImpItem :: ImpItemSpec -> Bool +selectiveImpItem ImpAll = False +selectiveImpItem (ImpSome {}) = True + +-- ToDo: deal with original imports with 'qualified' and 'as M' clauses +printMinimalImports :: FiniteMap Module AvailEnv -- Minimal imports + -> RnM () +printMinimalImports imps + = ifOptM Opt_D_dump_minimal_imports $ do { + + mod_ies <- mappM to_ies (fmToList imps) ; + this_mod <- getModule ; + rdr_env <- getGlobalRdrEnv ; + ioToTcRn (do { h <- openFile (mkFilename this_mod) WriteMode ; + printForUser h (unQualInScope rdr_env) + (vcat (map ppr_mod_ie mod_ies)) }) + } + where + mkFilename this_mod = moduleString this_mod ++ ".imports" + ppr_mod_ie (mod_name, ies) + | mod_name == pRELUDE + = empty + | null ies -- Nothing except instances comes from here + = ptext SLIT("import") <+> ppr mod_name <> ptext SLIT("() -- Instances only") + | otherwise + = ptext SLIT("import") <+> ppr mod_name <> + parens (fsep (punctuate comma (map ppr ies))) + + to_ies (mod, avail_env) = do ies <- mapM to_ie (availEnvElts avail_env) + returnM (mod, ies) + + to_ie :: AvailInfo -> RnM (IE Name) + -- 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) = returnM (IEVar n) + to_ie (AvailTC n [m]) = ASSERT( n==m ) + returnM (IEThingAbs n) + to_ie (AvailTC n ns) + = loadSrcInterface doc n_mod False `thenM` \ iface -> + case [xs | (m,as) <- mi_exports iface, + m == n_mod, + AvailTC x xs <- as, + x == nameOccName n] of + [xs] | all_used xs -> returnM (IEThingAll n) + | otherwise -> returnM (IEThingWith n (filter (/= n) ns)) + other -> pprTrace "to_ie" (ppr n <+> ppr n_mod <+> ppr other) $ + returnM (IEVar n) + where + all_used avail_occs = all (`elem` map nameOccName ns) avail_occs + doc = text "Compute minimal imports from" <+> ppr n + n_mod = nameModule n +\end{code} + + +%************************************************************************ +%* * +\subsection{Errors} +%* * +%************************************************************************ + +\begin{code} +badImportItemErr iface decl_spec ie + = sep [ptext SLIT("Module"), quotes (ppr (is_mod decl_spec)), source_import, + ptext SLIT("does not export"), quotes (ppr ie)] + where + source_import | mi_boot iface = ptext SLIT("(hi-boot interface)") + | otherwise = empty + +dodgyImportWarn item = dodgyMsg (ptext SLIT("import")) item +dodgyExportWarn item = dodgyMsg (ptext SLIT("export")) item + +dodgyMsg kind tc + = sep [ ptext SLIT("The") <+> kind <+> ptext SLIT("item") <+> quotes (ppr (IEThingAll tc)), + ptext SLIT("suggests that") <+> quotes (ppr tc) <+> ptext SLIT("has constructor or class methods"), + ptext SLIT("but it has none; it is a type synonym or abstract type or class") ] + +modExportErr mod + = hsep [ ptext SLIT("Unknown module in export list: module"), quotes (ppr mod)] + +exportItemErr export_item + = sep [ ptext SLIT("The export item") <+> quotes (ppr export_item), + ptext SLIT("attempts to export constructors or class methods that are not visible here") ] + +exportClashErr global_env name1 name2 ie1 ie2 + = vcat [ ptext SLIT("Conflicting exports for") <+> quotes (ppr occ) <> colon + , ppr_export ie1 name1 + , ppr_export ie2 name2 ] + where + occ = nameOccName name1 + ppr_export ie name = nest 2 (quotes (ppr ie) <+> ptext SLIT("exports") <+> + quotes (ppr name) <+> pprNameProvenance (get_gre name)) + + -- get_gre finds a GRE for the Name, so that we can show its provenance + get_gre name + = case lookupGRE_Name global_env name of + (gre:_) -> gre + [] -> pprPanic "exportClashErr" (ppr name) + +addDupDeclErr :: Name -> Name -> TcRn () +addDupDeclErr name_a name_b + = addErrAt (srcLocSpan loc2) $ + vcat [ptext SLIT("Multiple declarations of") <+> quotes (ppr name1), + ptext SLIT("Declared at:") <+> vcat [ppr (nameSrcLoc name1), ppr loc2]] + where + loc2 = nameSrcLoc name2 + (name1,name2) | nameSrcLoc name_a > nameSrcLoc name_b = (name_b,name_a) + | otherwise = (name_a,name_b) + -- Report the error at the later location + +dupExportWarn occ_name ie1 ie2 + = hsep [quotes (ppr occ_name), + ptext SLIT("is exported by"), quotes (ppr ie1), + ptext SLIT("and"), quotes (ppr ie2)] + +dupModuleExport mod + = hsep [ptext SLIT("Duplicate"), + quotes (ptext SLIT("Module") <+> ppr mod), + ptext SLIT("in export list")] + +moduleDeprec mod txt + = sep [ ptext SLIT("Module") <+> quotes (ppr mod) <+> ptext SLIT("is deprecated:"), + nest 4 (ppr txt) ] +\end{code} diff --git a/compiler/rename/RnSource.hi-boot-5 b/compiler/rename/RnSource.hi-boot-5 new file mode 100644 index 0000000000..1ec4d52522 --- /dev/null +++ b/compiler/rename/RnSource.hi-boot-5 @@ -0,0 +1,13 @@ +__interface RnSource 1 0 where +__export RnSource rnBindsAndThen rnBinds rnSrcDecls; + +1 rnBindsAndThen :: __forall [b] => [HsBinds.HsBindGroup RdrName.RdrName] + -> ([HsBinds.HsBindGroup Name.Name] + -> TcRnTypes.RnM (b, NameSet.FreeVars)) + -> TcRnTypes.RnM (b, NameSet.FreeVars) ; + +1 rnBinds :: [HsBinds.HsBindGroup RdrName.RdrName] + -> TcRnTypes.RnM ([HsBinds.HsBindGroup Name.Name], NameSet.DefUses) ; + +1 rnSrcDecls :: HsDecls.HsGroup RdrName.RdrName + -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name) diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs new file mode 100644 index 0000000000..9150440aee --- /dev/null +++ b/compiler/rename/RnSource.lhs @@ -0,0 +1,722 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[RnSource]{Main pass of renamer} + +\begin{code} +module RnSource ( + rnSrcDecls, addTcgDUs, + rnTyClDecls, checkModDeprec, + rnSplice, checkTH + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} RnExpr( rnLExpr ) + +import HsSyn +import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, globalRdrEnvElts, + GlobalRdrElt(..), isLocalGRE ) +import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars ) +import RnHsSyn +import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) +import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs ) +import RnEnv ( lookupLocalDataTcNames, + lookupLocatedTopBndrRn, lookupLocatedOccRn, + lookupOccRn, newLocalsRn, + bindLocatedLocalsFV, bindPatSigTyVarsFV, + bindTyVarsRn, extendTyVarEnvFVRn, + bindLocalNames, checkDupNames, mapFvRn + ) +import TcRnMonad + +import HscTypes ( FixityEnv, FixItem(..), + Deprecations, Deprecs(..), DeprecTxt, plusDeprecs ) +import Class ( FunDep ) +import Name ( Name, nameOccName ) +import NameSet +import NameEnv +import OccName ( occEnvElts ) +import Outputable +import SrcLoc ( Located(..), unLoc, getLoc, noLoc ) +import DynFlags ( DynFlag(..) ) +import Maybes ( seqMaybe ) +import Maybe ( isNothing ) +import BasicTypes ( Boxity(..) ) +\end{code} + +@rnSourceDecl@ `renames' declarations. +It simultaneously performs dependency analysis and precedence parsing. +It also does the following error checks: +\begin{enumerate} +\item +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.) +\item +Checks that all variable occurences are defined. +\item +Checks the @(..)@ etc constraints in the export list. +\end{enumerate} + + +\begin{code} +rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) + +rnSrcDecls (HsGroup { hs_valds = val_decls, + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_fixds = fix_decls, + hs_depds = deprec_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls }) + + = do { -- Deal with deprecations (returns only the extra deprecations) + deprecs <- rnSrcDeprecDecls deprec_decls ; + updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs }) + $ do { + + -- Deal with top-level fixity decls + -- (returns the total new fixity env) + fix_env <- rnSrcFixityDeclsEnv fix_decls ; + rn_fix_decls <- rnSrcFixityDecls fix_decls ; + updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env }) + $ do { + + -- Rename other declarations + traceRn (text "Start rnmono") ; + (rn_val_decls, bind_dus) <- rnTopBinds val_decls ; + traceRn (text "finish rnmono" <+> ppr rn_val_decls) ; + + -- 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. + (rn_tycl_decls, src_fvs1) + <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ; + (rn_inst_decls, src_fvs2) + <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ; + (rn_rule_decls, src_fvs3) + <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ; + (rn_foreign_decls, src_fvs4) + <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ; + (rn_default_decls, src_fvs5) + <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ; + + let { + rn_group = HsGroup { hs_valds = rn_val_decls, + hs_tyclds = rn_tycl_decls, + hs_instds = rn_inst_decls, + hs_fixds = rn_fix_decls, + hs_depds = [], + hs_fords = rn_foreign_decls, + hs_defds = rn_default_decls, + hs_ruleds = rn_rule_decls } ; + + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, + src_fvs4, src_fvs5] ; + src_dus = bind_dus `plusDU` usesOnly other_fvs + -- Note: src_dus will contain *uses* for locally-defined types + -- and classes, but no *defs* for them. (Because rnTyClDecl + -- returns only the uses.) This is a little + -- surprising but it doesn't actually matter at all. + } ; + + traceRn (text "finish rnSrc" <+> ppr rn_group) ; + traceRn (text "finish Dus" <+> ppr src_dus ) ; + tcg_env <- getGblEnv ; + return (tcg_env `addTcgDUs` src_dus, rn_group) + }}} + +rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name] +rnTyClDecls tycl_decls = do + (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls + return decls' + +addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv +addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } +\end{code} + + +%********************************************************* +%* * + Source-code fixity declarations +%* * +%********************************************************* + +\begin{code} +rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name] +rnSrcFixityDecls fix_decls + = do fix_decls <- mapM rnFixityDecl fix_decls + return (concat fix_decls) + +rnFixityDecl :: LFixitySig RdrName -> RnM [LFixitySig Name] +rnFixityDecl (L loc (FixitySig (L nameLoc rdr_name) fixity)) + = do names <- lookupLocalDataTcNames rdr_name + return [ L loc (FixitySig (L nameLoc name) fixity) + | name <- names ] + +rnSrcFixityDeclsEnv :: [LFixitySig RdrName] -> RnM FixityEnv +rnSrcFixityDeclsEnv fix_decls + = getGblEnv `thenM` \ gbl_env -> + foldlM rnFixityDeclEnv (tcg_fix_env gbl_env) + fix_decls `thenM` \ fix_env -> + traceRn (text "fixity env" <+> pprFixEnv fix_env) `thenM_` + returnM fix_env + +rnFixityDeclEnv :: FixityEnv -> LFixitySig RdrName -> RnM FixityEnv +rnFixityDeclEnv fix_env (L loc (FixitySig rdr_name fixity)) + = setSrcSpan loc $ + -- GHC extension: look up both the tycon and data con + -- for con-like things + -- If neither are in scope, report an error; otherwise + -- add both to the fixity env + addLocM lookupLocalDataTcNames rdr_name `thenM` \ names -> + foldlM add fix_env names + where + add fix_env name + = case lookupNameEnv fix_env name of + Just (FixItem _ _ loc') + -> addLocErr rdr_name (dupFixityDecl loc') `thenM_` + returnM fix_env + Nothing -> returnM (extendNameEnv fix_env name fix_item) + where + fix_item = FixItem (nameOccName name) fixity (getLoc rdr_name) + +pprFixEnv :: FixityEnv -> SDoc +pprFixEnv env + = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n) + (nameEnvElts env) + +dupFixityDecl loc rdr_name + = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), + ptext SLIT("also at ") <+> ppr loc + ] +\end{code} + + +%********************************************************* +%* * + Source-code deprecations declarations +%* * +%********************************************************* + +For deprecations, all we do is check that the names are in scope. +It's only imported deprecations, dealt with in RnIfaces, that we +gather them together. + +\begin{code} +rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations +rnSrcDeprecDecls [] + = returnM NoDeprecs + +rnSrcDeprecDecls decls + = mappM (addLocM rn_deprec) decls `thenM` \ pairs_s -> + returnM (DeprecSome (mkNameEnv (concat pairs_s))) + where + rn_deprec (Deprecation rdr_name txt) + = lookupLocalDataTcNames rdr_name `thenM` \ names -> + returnM [(name, (nameOccName name, txt)) | name <- names] + +checkModDeprec :: Maybe DeprecTxt -> Deprecations +-- Check for a module deprecation; done once at top level +checkModDeprec Nothing = NoDeprecs +checkModDeprec (Just txt) = DeprecAll txt +\end{code} + +%********************************************************* +%* * +\subsection{Source code declarations} +%* * +%********************************************************* + +\begin{code} +rnDefaultDecl (DefaultDecl tys) + = mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) -> + returnM (DefaultDecl tys', fvs) + where + doc_str = text "In a `default' declaration" +\end{code} + +%********************************************************* +%* * +\subsection{Foreign declarations} +%* * +%********************************************************* + +\begin{code} +rnHsForeignDecl (ForeignImport name ty spec isDeprec) + = lookupLocatedTopBndrRn name `thenM` \ name' -> + rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> + returnM (ForeignImport name' ty' spec isDeprec, fvs) + +rnHsForeignDecl (ForeignExport name ty spec isDeprec) + = lookupLocatedOccRn name `thenM` \ name' -> + rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> + returnM (ForeignExport name' ty' spec isDeprec, fvs ) + -- 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 + +fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name +\end{code} + + +%********************************************************* +%* * +\subsection{Instance declarations} +%* * +%********************************************************* + +\begin{code} +rnSrcInstDecl (InstDecl inst_ty mbinds uprags) + -- Used for both source and interface file decls + = rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' -> + + -- Rename the bindings + -- The typechecker (not the renamer) checks that all + -- the bindings are for the right class + let + meth_doc = text "In the bindings in an instance declaration" + meth_names = collectHsBindLocatedBinders mbinds + (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty') + in + checkDupNames meth_doc meth_names `thenM_` + extendTyVarEnvForMethodBinds inst_tyvars ( + -- (Slightly strangely) the forall-d tyvars scope over + -- the method bindings too + rnMethodBinds cls [] mbinds + ) `thenM` \ (mbinds', meth_fvs) -> + -- Rename the prags and signatures. + -- Note that the type variables are not in scope here, + -- so that instance Eq a => Eq (T a) where + -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-} + -- works OK. + -- + -- But the (unqualified) method names are in scope + let + binders = collectHsBindBinders mbinds' + ok_sig = okInstDclSig (mkNameSet binders) + in + bindLocalNames binders (renameSigs ok_sig uprags) `thenM` \ uprags' -> + + returnM (InstDecl inst_ty' mbinds' uprags', + meth_fvs `plusFV` hsSigsFVs uprags' + `plusFV` extractHsTyNames inst_ty') +\end{code} + +For the method bindings in class and instance decls, we extend the +type variable environment iff -fglasgow-exts + +\begin{code} +extendTyVarEnvForMethodBinds tyvars thing_inside + = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> + if opt_GlasgowExts then + extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside + else + thing_inside +\end{code} + + +%********************************************************* +%* * +\subsection{Rules} +%* * +%********************************************************* + +\begin{code} +rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs) + = bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $ + + bindLocatedLocalsFV doc (map get_var vars) $ \ ids -> + mapFvRn rn_var (vars `zip` ids) `thenM` \ (vars', fv_vars) -> + + rnLExpr lhs `thenM` \ (lhs', fv_lhs') -> + rnLExpr rhs `thenM` \ (rhs', fv_rhs') -> + let + mb_bad = validRuleLhs ids lhs' + in + checkErr (isNothing mb_bad) + (badRuleLhsErr rule_name lhs' mb_bad) `thenM_` + let + bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] + in + mappM (addErr . badRuleVar rule_name) bad_vars `thenM_` + returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs', + fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') + where + doc = text "In the transformation rule" <+> ftext rule_name + + get_var (RuleBndr v) = v + get_var (RuleBndrSig v _) = v + + rn_var (RuleBndr (L loc v), id) + = returnM (RuleBndr (L loc id), emptyFVs) + rn_var (RuleBndrSig (L loc v) t, id) + = rnHsTypeFVs doc t `thenM` \ (t', fvs) -> + returnM (RuleBndrSig (L loc id) t', fvs) +\end{code} + +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 also restrict the form of the LHS so +that it may be plausibly matched. Basically you only get to write ordinary +applications. (E.g. a case expression is not allowed: too elaborate.) + +NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs + +\begin{code} +validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name) +-- Nothing => OK +-- Just e => Not ok, and e is the offending expression +validRuleLhs foralls lhs + = checkl lhs + where + checkl (L loc e) = check e + + check (OpApp e1 op _ e2) = checkl op `seqMaybe` checkl_e e1 `seqMaybe` checkl_e e2 + check (HsApp e1 e2) = checkl e1 `seqMaybe` checkl_e e2 + check (HsVar v) | v `notElem` foralls = Nothing + check other = Just other -- Failure + + checkl_e (L loc e) = check_e e + + 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 `seqMaybe` checkl_e op `seqMaybe` checkl_e e2 + check_e (HsApp e1 e2) = checkl_e e1 `seqMaybe` checkl_e e2 + check_e (NegApp e _) = checkl_e e + check_e (ExplicitList _ es) = checkl_es es + check_e (ExplicitTuple es _) = checkl_es es + check_e other = Just other -- Fails + + checkl_es es = foldr (seqMaybe . checkl_e) Nothing es + +badRuleLhsErr name lhs (Just bad_e) + = sep [ptext SLIT("Rule") <+> ftext name <> colon, + nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e, + ptext SLIT("in left-hand side:") <+> ppr lhs])] + $$ + ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd") + +badRuleVar name var + = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon, + ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> + ptext SLIT("does not appear on left hand side")] +\end{code} + + +%********************************************************* +%* * +\subsection{Type, class and iface sig 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. + +\begin{code} +rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name}) + = lookupLocatedTopBndrRn name `thenM` \ name' -> + returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name}, + emptyFVs) + +rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, + tcdTyVars = tyvars, tcdCons = condecls, + tcdKindSig = sig, tcdDerivs = derivs}) + | is_vanilla -- Normal Haskell data type decl + = ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the + -- data type is syntactically illegal + bindTyVarsRn data_doc tyvars $ \ tyvars' -> + do { tycon' <- lookupLocatedTopBndrRn tycon + ; context' <- rnContext data_doc context + ; (derivs', deriv_fvs) <- rn_derivs derivs + ; checkDupNames data_doc con_names + ; condecls' <- rnConDecls (unLoc tycon') condecls + ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', + tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls', + tcdDerivs = derivs'}, + delFVs (map hsLTyVarName tyvars') $ + extractHsCtxtTyNames context' `plusFV` + plusFVs (map conDeclFVs condecls') `plusFV` + deriv_fvs) } + + | otherwise -- GADT + = do { tycon' <- lookupLocatedTopBndrRn tycon + ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon) + ; tyvars' <- bindTyVarsRn data_doc tyvars + (\ tyvars' -> return tyvars') + -- For GADTs, the type variables in the declaration + -- do not scope over the constructor signatures + -- data T a where { T1 :: forall b. b-> b } + ; (derivs', deriv_fvs) <- rn_derivs derivs + ; checkDupNames data_doc con_names + ; condecls' <- rnConDecls (unLoc tycon') condecls + ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon', + tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig, + tcdDerivs = derivs'}, + plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) } + + where + is_vanilla = case condecls of -- Yuk + [] -> True + L _ (ConDecl { con_res = ResTyH98 }) : _ -> True + other -> False + + data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) + con_names = map con_names_helper condecls + + con_names_helper (L _ c) = con_name c + + rn_derivs Nothing = returnM (Nothing, emptyFVs) + rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' -> + returnM (Just ds', extractHsTyNames_s ds') + +rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty}) + = lookupLocatedTopBndrRn name `thenM` \ name' -> + bindTyVarsRn syn_doc tyvars $ \ tyvars' -> + rnHsTypeFVs syn_doc ty `thenM` \ (ty', fvs) -> + returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars', + tcdSynRhs = ty'}, + delFVs (map hsLTyVarName tyvars') fvs) + where + syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) + +rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, + tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, + tcdMeths = mbinds}) + = lookupLocatedTopBndrRn cname `thenM` \ cname' -> + + -- Tyvars scope over superclass context and method signatures + bindTyVarsRn cls_doc tyvars ( \ tyvars' -> + rnContext cls_doc context `thenM` \ context' -> + rnFds cls_doc fds `thenM` \ fds' -> + renameSigs okClsDclSig sigs `thenM` \ sigs' -> + returnM (tyvars', context', fds', sigs') + ) `thenM` \ (tyvars', context', fds', sigs') -> + + -- 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 _ (TypeSig op _) <- sigs] + in + checkDupNames sig_doc sig_rdr_names_w_locs `thenM_` + -- 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. + extendTyVarEnvForMethodBinds tyvars' ( + getLocalRdrEnv `thenM` \ name_env -> + let + meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds + gen_rdr_tyvars_w_locs = + [ tv | tv <- extractGenericPatTyVars mbinds, + not (unLoc tv `elemLocalRdrEnv` name_env) ] + in + checkDupNames meth_doc meth_rdr_names_w_locs `thenM_` + newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars -> + rnMethodBinds (unLoc cname') gen_tyvars mbinds + ) `thenM` \ (mbinds', meth_fvs) -> + + returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars', + tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds'}, + delFVs (map hsLTyVarName tyvars') $ + extractHsCtxtTyNames context' `plusFV` + plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV` + hsSigsFVs sigs' `plusFV` + meth_fvs) + where + meth_doc = text "In the default-methods for class" <+> ppr cname + cls_doc = text "In the declaration for class" <+> ppr cname + sig_doc = text "In the signatures for class" <+> ppr cname + +badGadtStupidTheta tycon + = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"), + ptext SLIT("(You can put a context on each contructor, though.)")] +\end{code} + +%********************************************************* +%* * +\subsection{Support code for type/data declarations} +%* * +%********************************************************* + +\begin{code} +rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name] +rnConDecls tycon condecls + = mappM (wrapLocM rnConDecl) condecls + +rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name) +rnConDecl (ConDecl name expl tvs cxt details res_ty) + = do { addLocM checkConName name + + ; new_name <- lookupLocatedTopBndrRn name + ; name_env <- getLocalRdrEnv + + -- For H98 syntax, the tvs are the existential ones + -- For GADT syntax, the tvs are all the quantified tyvars + -- Hence the 'filter' in the ResTyH98 case only + ; let not_in_scope = not . (`elemLocalRdrEnv` name_env) . unLoc + arg_tys = hsConArgs details + implicit_tvs = case res_ty of + ResTyH98 -> filter not_in_scope $ + get_rdr_tvs arg_tys + ResTyGADT ty -> get_rdr_tvs (ty : arg_tys) + tvs' = case expl of + Explicit -> tvs + Implicit -> userHsTyVarBndrs implicit_tvs + + ; bindTyVarsRn doc tvs' $ \new_tyvars -> do + { new_context <- rnContext doc cxt + ; new_details <- rnConDetails doc details + ; new_res_ty <- rnConResult doc res_ty + ; let rv = ConDecl new_name expl new_tyvars new_context new_details new_res_ty + ; traceRn (text "****** - autrijus" <> ppr rv) + ; return rv } } + where + doc = text "In the definition of data constructor" <+> quotes (ppr name) + get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys)) + +rnConResult _ ResTyH98 = return ResTyH98 +rnConResult doc (ResTyGADT ty) = do + ty' <- rnHsSigType doc ty + return $ ResTyGADT ty' + +rnConDetails doc (PrefixCon tys) + = mappM (rnLHsType doc) tys `thenM` \ new_tys -> + returnM (PrefixCon new_tys) + +rnConDetails doc (InfixCon ty1 ty2) + = rnLHsType doc ty1 `thenM` \ new_ty1 -> + rnLHsType doc ty2 `thenM` \ new_ty2 -> + returnM (InfixCon new_ty1 new_ty2) + +rnConDetails doc (RecCon fields) + = checkDupNames doc field_names `thenM_` + mappM (rnField doc) fields `thenM` \ new_fields -> + returnM (RecCon new_fields) + where + field_names = [fld | (fld, _) <- fields] + +rnField doc (name, ty) + = lookupLocatedTopBndrRn name `thenM` \ new_name -> + rnLHsType doc ty `thenM` \ new_ty -> + returnM (new_name, new_ty) + +-- 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 name = checkErr (isRdrDataCon name) (badDataCon name) + +badDataCon name + = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] +\end{code} + + +%********************************************************* +%* * +\subsection{Support code to rename types} +%* * +%********************************************************* + +\begin{code} +rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)] + +rnFds doc fds + = mappM (wrapLocM rn_fds) fds + where + rn_fds (tys1, tys2) + = rnHsTyVars doc tys1 `thenM` \ tys1' -> + rnHsTyVars doc tys2 `thenM` \ tys2' -> + returnM (tys1', tys2') + +rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs +rnHsTyvar doc tyvar = lookupOccRn tyvar +\end{code} + + +%********************************************************* +%* * + Splices +%* * +%********************************************************* + +Note [Splices] +~~~~~~~~~~~~~~ +Consider + f = ... + h = ...$(thing "f")... + +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. + +\begin{code} +rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) +rnSplice (HsSplice n expr) + = do { checkTH expr "splice" + ; loc <- getSrcSpanM + ; [n'] <- newLocalsRn [L loc n] + ; (expr', fvs) <- rnLExpr expr + + -- Ugh! See Note [Splices] above + ; lcl_rdr <- getLocalRdrEnv + ; gbl_rdr <- getGlobalRdrEnv + ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, + isLocalGRE gre] + lcl_names = mkNameSet (occEnvElts lcl_rdr) + + ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) } + +#ifdef GHCI +checkTH e what = returnM () -- OK +#else +checkTH e what -- Raise an error in a stage-1 compiler + = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+> + ptext SLIT("illegal in a stage-1 compiler"), + nest 2 (ppr e)]) +#endif +\end{code} diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs new file mode 100644 index 0000000000..d7d435ce97 --- /dev/null +++ b/compiler/rename/RnTypes.lhs @@ -0,0 +1,766 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[RnSource]{Main pass of renamer} + +\begin{code} +module RnTypes ( + -- Type related stuff + rnHsType, rnLHsType, rnLHsTypes, rnContext, + rnHsSigType, rnHsTypeFVs, + + -- Patterns and literals + rnLPat, rnPat, rnPatsAndThen, -- Here because it's not part + rnLit, rnOverLit, -- of any mutual recursion + + -- Precence related stuff + mkOpAppRn, mkNegAppRn, mkOpFormRn, + checkPrecMatch, checkSectionPrec, + + -- Error messages + dupFieldErr, patSigErr, checkTupSize + ) where + +import DynFlags ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) ) + +import HsSyn +import RdrHsSyn ( extractHsRhoRdrTyVars ) +import RnHsSyn ( extractHsTyNames, parrTyCon_name, tupleTyCon_name, + listTyCon_name + ) +import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, + lookupLocatedOccRn, lookupLocatedBndrRn, + lookupLocatedGlobalOccRn, bindTyVarsRn, + lookupFixityRn, lookupTyFixityRn, + mapFvRn, warnUnusedMatches, + newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV ) +import TcRnMonad +import RdrName ( RdrName, elemLocalRdrEnv ) +import PrelNames ( eqClassName, integralClassName, geName, eqName, + negateName, minusName, lengthPName, indexPName, + plusIntegerName, fromIntegerName, timesIntegerName, + ratioDataConName, fromRationalName ) +import TypeRep ( funTyCon ) +import Constants ( mAX_TUPLE_SIZE ) +import Name ( Name ) +import SrcLoc ( SrcSpan, Located(..), unLoc, noLoc, combineLocs ) +import NameSet + +import Literal ( inIntRange, inCharRange ) +import BasicTypes ( compareFixity, funTyFixity, negateFixity, + Fixity(..), FixityDirection(..) ) +import ListSetOps ( removeDups ) +import Outputable + +#include "HsVersions.h" +\end{code} + +These type renamers are in a separate module, rather than in (say) RnSource, +to break several loop. + +%********************************************************* +%* * +\subsection{Renaming types} +%* * +%********************************************************* + +\begin{code} +rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +rnHsTypeFVs doc_str ty + = rnLHsType doc_str ty `thenM` \ ty' -> + returnM (ty', extractHsTyNames ty') + +rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name) + -- rnHsSigType is used for source-language type signatures, + -- which use *implicit* universal quantification. +rnHsSigType doc_str ty + = rnLHsType (text "In the type signature for" <+> doc_str) ty +\end{code} + +rnHsType is here because we call it from loadInstDecl, and I didn't +want a gratuitous knot. + +\begin{code} +rnLHsType :: SDoc -> LHsType RdrName -> RnM (LHsType Name) +rnLHsType doc = wrapLocM (rnHsType doc) + +rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name) + +rnHsType doc (HsForAllTy Implicit _ ctxt ty) + -- Implicit quantifiction in source code (no kinds on tyvars) + -- Given the signature C => T we universally quantify + -- over FV(T) \ {in-scope-tyvars} + = getLocalRdrEnv `thenM` \ name_env -> + let + mentioned = extractHsRhoRdrTyVars ctxt ty + + -- Don't quantify over type variables that are in scope; + -- when GlasgowExts is off, there usually won't be any, except for + -- class signatures: + -- class C a where { op :: a -> a } + forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned + tyvar_bndrs = userHsTyVarBndrs forall_tyvars + in + rnForAll doc Implicit tyvar_bndrs ctxt ty + +rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau) + -- Explicit quantification. + -- Check that the forall'd tyvars are actually + -- mentioned in the type, and produce a warning if not + = let + mentioned = map unLoc (extractHsRhoRdrTyVars ctxt tau) + forall_tyvar_names = hsLTyVarLocNames forall_tyvars + + -- Explicitly quantified but not mentioned in ctxt or tau + warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names + in + mappM_ (forAllWarn doc tau) warn_guys `thenM_` + rnForAll doc Explicit forall_tyvars ctxt tau + +rnHsType doc (HsTyVar tyvar) + = lookupOccRn tyvar `thenM` \ tyvar' -> + returnM (HsTyVar tyvar') + +rnHsType doc (HsOpTy ty1 (L loc op) ty2) + = setSrcSpan loc ( + lookupOccRn op `thenM` \ op' -> + let + l_op' = L loc op' + in + lookupTyFixityRn l_op' `thenM` \ fix -> + rnLHsType doc ty1 `thenM` \ ty1' -> + rnLHsType doc ty2 `thenM` \ ty2' -> + mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) (ppr op') fix ty1' ty2' + ) + +rnHsType doc (HsParTy ty) + = rnLHsType doc ty `thenM` \ ty' -> + returnM (HsParTy ty') + +rnHsType doc (HsBangTy b ty) + = rnLHsType doc ty `thenM` \ ty' -> + returnM (HsBangTy b ty') + +rnHsType doc (HsNumTy i) + | i == 1 = returnM (HsNumTy i) + | otherwise = addErr err_msg `thenM_` returnM (HsNumTy i) + where + err_msg = ptext SLIT("Only unit numeric type pattern is valid") + + +rnHsType doc (HsFunTy ty1 ty2) + = rnLHsType doc ty1 `thenM` \ ty1' -> + -- Might find a for-all as the arg of a function type + rnLHsType doc ty2 `thenM` \ 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 + mkHsOpTyRn HsFunTy (ppr funTyCon) funTyFixity ty1' ty2' + +rnHsType doc (HsListTy ty) + = rnLHsType doc ty `thenM` \ ty' -> + returnM (HsListTy ty') + +rnHsType doc (HsKindSig ty k) + = rnLHsType doc ty `thenM` \ ty' -> + returnM (HsKindSig ty' k) + +rnHsType doc (HsPArrTy ty) + = rnLHsType doc ty `thenM` \ ty' -> + returnM (HsPArrTy ty') + +-- Unboxed tuples are allowed to have poly-typed arguments. These +-- sometimes crop up as a result of CPR worker-wrappering dictionaries. +rnHsType doc (HsTupleTy tup_con tys) + = mappM (rnLHsType doc) tys `thenM` \ tys' -> + returnM (HsTupleTy tup_con tys') + +rnHsType doc (HsAppTy ty1 ty2) + = rnLHsType doc ty1 `thenM` \ ty1' -> + rnLHsType doc ty2 `thenM` \ ty2' -> + returnM (HsAppTy ty1' ty2') + +rnHsType doc (HsPredTy pred) + = rnPred doc pred `thenM` \ pred' -> + returnM (HsPredTy pred') + +rnHsType doc (HsSpliceTy _) + = do { addErr (ptext SLIT("Type splices are not yet implemented")) + ; failM } + +rnLHsTypes doc tys = mappM (rnLHsType doc) tys +\end{code} + + +\begin{code} +rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName] + -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name) + +rnForAll doc exp [] (L _ []) (L _ ty) = rnHsType doc ty + -- One reason for this case is that a type like Int# + -- starts off as (HsForAllTy Nothing [] Int), in case + -- there is some quantification. Now that we have quantified + -- and discovered there are no type variables, it's nicer to turn + -- it into plain Int. If it were Int# instead of Int, we'd actually + -- get an error, because the body of a genuine for-all is + -- of kind *. + +rnForAll doc exp forall_tyvars ctxt ty + = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> + rnContext doc ctxt `thenM` \ new_ctxt -> + rnLHsType doc ty `thenM` \ new_ty -> + returnM (HsForAllTy exp new_tyvars new_ctxt new_ty) + -- Retain the same implicit/explicit flag as before + -- so that we can later print it correctly +\end{code} + + +%************************************************************************ +%* * + 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 appications 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. + +\begin{code} +--------------- +-- Building (ty1 `op1` (ty21 `op2` ty22)) +mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name) + -> SDoc -> Fixity -> LHsType Name -> LHsType Name + -> RnM (HsType Name) + +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22)) + = do { fix2 <- lookupTyFixityRn op2 + ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 + (\t1 t2 -> HsOpTy t1 op2 t2) + (ppr op2) fix2 ty21 ty22 loc2 } + +mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty2@(L loc2 (HsFunTy ty21 ty22)) + = mk_hs_op_ty mk1 pp_op1 fix1 ty1 + HsFunTy (ppr funTyCon) funTyFixity ty21 ty22 loc2 + +mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty2 -- Default case, no rearrangment + = return (mk1 ty1 ty2) + +--------------- +mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name) + -> SDoc -> Fixity -> LHsType Name + -> (LHsType Name -> LHsType Name -> HsType Name) + -> SDoc -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan + -> RnM (HsType Name) +mk_hs_op_ty mk1 pp_op1 fix1 ty1 + mk2 pp_op2 fix2 ty21 ty22 loc2 + | nofix_error = do { addErr (precParseErr (quotes pp_op1,fix1) + (quotes pp_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 pp_op1 fix1 ty1 ty21 + ; return (mk2 (noLoc new_ty) ty22) } + where + (nofix_error, associate_right) = compareFixity fix1 fix2 + + +--------------------------- +mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged + -> LHsExpr Name -> Fixity -- Operator and fixity + -> LHsExpr Name -- Right operand (not an OpApp, but might + -- be a NegApp) + -> RnM (HsExpr Name) + +-- (e11 `op1` e12) `op2` e2 +mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 + | nofix_error + = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` + returnM (OpApp e1 op2 fix2 e2) + + | associate_right + = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e -> + returnM (OpApp e11 op1 fix1 (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 + = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_` + returnM (OpApp e1 op2 fix2 e2) + + | associate_right + = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e -> + returnM (NegApp (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 neg_arg _)) -- NegApp can occur on the right + | not associate_right -- We *want* right association + = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_` + returnM (OpApp e1 op1 fix1 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 + ) + returnM (OpApp e1 op fix e2) + +-- Parser left-associates everything, but +-- derived instances may have correctly-associated things to +-- in the right operarand. So we just check that the right operand is OK +right_op_ok fix1 (OpApp _ _ fix2 _) + = not error_please && associate_right + where + (error_please, associate_right) = compareFixity fix1 fix2 +right_op_ok fix1 other + = True + +-- Parser initially makes negation bind more tightly than any other operator +-- And "deriving" code should respect this (use HsPar if not) +mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id) +mkNegAppRn neg_arg neg_name + = ASSERT( not_op_app (unLoc neg_arg) ) + returnM (NegApp neg_arg neg_name) + +not_op_app (OpApp _ _ _ _) = False +not_op_app other = True + +--------------------------- +mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged + -> LHsExpr Name -> Fixity -- Operator and fixity + -> LHsCmdTop Name -- Right operand (not an infix) + -> RnM (HsCmd Name) + +-- (e11 `op1` e12) `op2` e2 +mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _)) + op2 fix2 a2 + | nofix_error + = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` + returnM (HsArrForm op2 (Just fix2) [a1, a2]) + + | associate_right + = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c -> + returnM (HsArrForm op1 (Just fix1) + [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])]) + -- TODO: locs are wrong + where + (nofix_error, associate_right) = compareFixity fix1 fix2 + +-- Default case +mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment + = returnM (HsArrForm op (Just fix) [arg1, arg2]) + + +-------------------------------------- +mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name + -> RnM (Pat Name) + +mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 + = lookupFixityRn (unLoc op1) `thenM` \ fix1 -> + let + (nofix_error, associate_right) = compareFixity fix1 fix2 + in + if nofix_error then + addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` + returnM (ConPatIn op2 (InfixCon p1 p2)) + else + if associate_right then + mkConOpPatRn op2 fix2 p12 p2 `thenM` \ new_p -> + returnM (ConPatIn op1 (InfixCon p11 (L loc new_p))) -- XXX loc right? + else + returnM (ConPatIn op2 (InfixCon p1 p2)) + +mkConOpPatRn op fix p1 p2 -- Default case, no rearrangment + = ASSERT( not_op_pat (unLoc p2) ) + returnM (ConPatIn op (InfixCon p1 p2)) + +not_op_pat (ConPatIn _ (InfixCon _ _)) = False +not_op_pat other = True + +-------------------------------------- +checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM () + -- True indicates an infix lhs + -- See comments with rnExpr (OpApp ...) about "deriving" + +checkPrecMatch False fn match + = returnM () +checkPrecMatch True op (MatchGroup ms _) + = mapM_ check ms + where + check (L _ (Match (p1:p2:_) _ _)) + = checkPrec op (unLoc p1) False `thenM_` + checkPrec op (unLoc p2) True + + check _ = panic "checkPrecMatch" + +checkPrec op (ConPatIn op1 (InfixCon _ _)) right + = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) -> + lookupFixityRn (unLoc op1) `thenM` \ op1_fix@(Fixity op1_prec op1_dir) -> + 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 = (ppr_op op, op_fix) + info1 = (ppr_op op1, op1_fix) + (infol, infor) = if right then (info, info1) else (info1, info) + in + checkErr inf_ok (precParseErr infol infor) + +checkPrec op pat right + = returnM () + +-- 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 RdrName + -> LHsExpr Name -> LHsExpr Name -> RnM () +checkSectionPrec direction section op arg + = case unLoc arg of + OpApp _ op fix _ -> go_for_it (ppr_op op) fix + NegApp _ _ -> go_for_it pp_prefix_minus negateFixity + other -> returnM () + where + L _ (HsVar op_name) = op + go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc) + = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) -> + checkErr (op_prec < arg_prec + || op_prec == arg_prec && direction == assoc) + (sectionPrecErr (ppr_op op_name, op_fix) + (pp_arg_op, arg_fix) section) +\end{code} + +Precedence-related error messages + +\begin{code} +precParseErr op1 op2 + = hang (ptext SLIT("precedence parsing error")) + 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"), + ppr_opfix op2, + ptext SLIT("in the same infix expression")]) + +sectionPrecErr op arg_op section + = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"), + nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op), + nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))] + +pp_prefix_minus = ptext SLIT("prefix `-'") +ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name +ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity) +\end{code} + +%********************************************************* +%* * +\subsection{Contexts and predicates} +%* * +%********************************************************* + +\begin{code} +rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name) +rnContext doc = wrapLocM (rnContext' doc) + +rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name) +rnContext' doc ctxt = mappM (rnLPred doc) ctxt + +rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name) +rnLPred doc = wrapLocM (rnPred doc) + +rnPred doc (HsClassP clas tys) + = lookupOccRn clas `thenM` \ clas_name -> + rnLHsTypes doc tys `thenM` \ tys' -> + returnM (HsClassP clas_name tys') + +rnPred doc (HsIParam n ty) + = newIPNameRn n `thenM` \ name -> + rnLHsType doc ty `thenM` \ ty' -> + returnM (HsIParam name ty') +\end{code} + + +********************************************************* +* * +\subsection{Patterns} +* * +********************************************************* + +\begin{code} +rnPatsAndThen :: HsMatchContext Name + -> [LPat RdrName] + -> ([LPat Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +-- Bring into scope all the binders and type variables +-- bound by the patterns; then rename the patterns; then +-- do the thing inside. +-- +-- Note that we do a single bindLocalsRn for all the +-- matches together, so that we spot the repeated variable in +-- f x x = 1 + +rnPatsAndThen ctxt pats thing_inside + = bindPatSigTyVarsFV pat_sig_tys $ + bindLocatedLocalsFV doc_pat bndrs $ \ new_bndrs -> + rnLPats pats `thenM` \ (pats', pat_fvs) -> + thing_inside pats' `thenM` \ (res, res_fvs) -> + + let + unused_binders = filter (not . (`elemNameSet` res_fvs)) new_bndrs + in + warnUnusedMatches unused_binders `thenM_` + returnM (res, res_fvs `plusFV` pat_fvs) + where + pat_sig_tys = collectSigTysFromPats pats + bndrs = collectLocatedPatsBinders pats + doc_pat = ptext SLIT("In") <+> pprMatchContext ctxt + +rnLPats :: [LPat RdrName] -> RnM ([LPat Name], FreeVars) +rnLPats ps = mapFvRn rnLPat ps + +rnLPat :: LPat RdrName -> RnM (LPat Name, FreeVars) +rnLPat = wrapLocFstM rnPat + +-- ----------------------------------------------------------------------------- +-- rnPat + +rnPat :: Pat RdrName -> RnM (Pat Name, FreeVars) + +rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs) + +rnPat (VarPat name) + = lookupBndrRn name `thenM` \ vname -> + returnM (VarPat vname, emptyFVs) + +rnPat (SigPatIn pat ty) + = doptM Opt_GlasgowExts `thenM` \ glaExts -> + + if glaExts + then rnLPat pat `thenM` \ (pat', fvs1) -> + rnHsTypeFVs doc ty `thenM` \ (ty', fvs2) -> + returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2) + + else addErr (patSigErr ty) `thenM_` + rnPat (unLoc pat) -- XXX shouldn't throw away the loc + where + doc = text "In a pattern type-signature" + +rnPat (LitPat lit) + = rnLit lit `thenM_` + returnM (LitPat lit, emptyFVs) + +rnPat (NPat lit mb_neg eq _) + = rnOverLit lit `thenM` \ (lit', fvs1) -> + (case mb_neg of + Nothing -> returnM (Nothing, emptyFVs) + Just _ -> lookupSyntaxName negateName `thenM` \ (neg, fvs) -> + returnM (Just neg, fvs) + ) `thenM` \ (mb_neg', fvs2) -> + lookupSyntaxName eqName `thenM` \ (eq', fvs3) -> + returnM (NPat lit' mb_neg' eq' placeHolderType, + fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` eqClassName) + -- Needed to find equality on pattern + +rnPat (NPlusKPat name lit _ _) + = rnOverLit lit `thenM` \ (lit', fvs1) -> + lookupLocatedBndrRn name `thenM` \ name' -> + lookupSyntaxName minusName `thenM` \ (minus, fvs2) -> + lookupSyntaxName geName `thenM` \ (ge, fvs3) -> + returnM (NPlusKPat name' lit' ge minus, + fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` integralClassName) + -- The Report says that n+k patterns must be in Integral + +rnPat (LazyPat pat) + = rnLPat pat `thenM` \ (pat', fvs) -> + returnM (LazyPat pat', fvs) + +rnPat (BangPat pat) + = rnLPat pat `thenM` \ (pat', fvs) -> + returnM (BangPat pat', fvs) + +rnPat (AsPat name pat) + = rnLPat pat `thenM` \ (pat', fvs) -> + lookupLocatedBndrRn name `thenM` \ vname -> + returnM (AsPat vname pat', fvs) + +rnPat (ConPatIn con stuff) = rnConPat con stuff + + +rnPat (ParPat pat) + = rnLPat pat `thenM` \ (pat', fvs) -> + returnM (ParPat pat', fvs) + +rnPat (ListPat pats _) + = rnLPats pats `thenM` \ (patslist, fvs) -> + returnM (ListPat patslist placeHolderType, fvs `addOneFV` listTyCon_name) + +rnPat (PArrPat pats _) + = rnLPats pats `thenM` \ (patslist, fvs) -> + returnM (PArrPat patslist placeHolderType, + fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name) + where + implicit_fvs = mkFVs [lengthPName, indexPName] + +rnPat (TuplePat pats boxed _) + = checkTupSize tup_size `thenM_` + rnLPats pats `thenM` \ (patslist, fvs) -> + returnM (TuplePat patslist boxed placeHolderType, + fvs `addOneFV` tycon_name) + where + tup_size = length pats + tycon_name = tupleTyCon_name boxed tup_size + +rnPat (TypePat name) = + rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) -> + returnM (TypePat name', fvs) + +-- ----------------------------------------------------------------------------- +-- rnConPat + +rnConPat con (PrefixCon pats) + = lookupLocatedOccRn con `thenM` \ con' -> + rnLPats pats `thenM` \ (pats', fvs) -> + returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` unLoc con') + +rnConPat con (RecCon rpats) + = lookupLocatedOccRn con `thenM` \ con' -> + rnRpats rpats `thenM` \ (rpats', fvs) -> + returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con') + +rnConPat con (InfixCon pat1 pat2) + = lookupLocatedOccRn con `thenM` \ con' -> + rnLPat pat1 `thenM` \ (pat1', fvs1) -> + rnLPat pat2 `thenM` \ (pat2', fvs2) -> + lookupFixityRn (unLoc con') `thenM` \ fixity -> + mkConOpPatRn con' fixity pat1' pat2' `thenM` \ pat' -> + returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` unLoc con') + +-- ----------------------------------------------------------------------------- +-- rnRpats + +rnRpats :: [(Located RdrName, LPat RdrName)] + -> RnM ([(Located Name, LPat Name)], FreeVars) +rnRpats rpats + = mappM_ field_dup_err dup_fields `thenM_` + mapFvRn rn_rpat rpats `thenM` \ (rpats', fvs) -> + returnM (rpats', fvs) + where + (_, dup_fields) = removeDups compare [ unLoc f | (f,_) <- rpats ] + + field_dup_err dups = addErr (dupFieldErr "pattern" dups) + + rn_rpat (field, pat) + = lookupLocatedGlobalOccRn field `thenM` \ fieldname -> + rnLPat pat `thenM` \ (pat', fvs) -> + returnM ((fieldname, pat'), fvs `addOneFV` unLoc fieldname) + +\end{code} + + +%************************************************************************ +%* * +\subsubsection{Literals} +%* * +%************************************************************************ + +When literals occur we have to make sure +that the types and classes they involve +are made available. + +\begin{code} +rnLit :: HsLit -> RnM () +rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c) +rnLit other = returnM () + +rnOverLit (HsIntegral i _) + = lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) -> + if inIntRange i then + returnM (HsIntegral i from_integer_name, fvs) + else let + extra_fvs = mkFVs [plusIntegerName, timesIntegerName] + -- Big integer literals are built, using + and *, + -- out of small integers (DsUtils.mkIntegerLit) + -- [NB: plusInteger, timesInteger aren't rebindable... + -- they are used to construct the argument to fromInteger, + -- which is the rebindable one.] + in + returnM (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs) + +rnOverLit (HsFractional i _) + = lookupSyntaxName fromRationalName `thenM` \ (from_rat_name, fvs) -> + let + extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName] + -- We have to make sure that the Ratio type is imported with + -- its constructor, because literals of type Ratio t are + -- built with that constructor. + -- The Rational type is needed too, but that will come in + -- as part of the type for fromRational. + -- The plus/times integer operations may be needed to construct the numerator + -- and denominator (see DsUtils.mkIntegerLit) + in + returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs) +\end{code} + + + +%********************************************************* +%* * +\subsection{Errors} +%* * +%********************************************************* + +\begin{code} +checkTupSize :: Int -> RnM () +checkTupSize tup_size + | tup_size <= mAX_TUPLE_SIZE + = returnM () + | otherwise + = addErr (sep [ptext SLIT("A") <+> int tup_size <> ptext SLIT("-tuple is too large for GHC"), + nest 2 (parens (ptext SLIT("max size is") <+> int mAX_TUPLE_SIZE)), + nest 2 (ptext SLIT("Workaround: use nested tuples or define a data type"))]) + +forAllWarn doc ty (L loc tyvar) + = ifOptM Opt_WarnUnusedMatches $ + setSrcSpan loc $ + addWarn (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar), + nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))] + $$ + doc + ) + +bogusCharError c + = ptext SLIT("character literal out of range: '\\") <> char c <> char '\'' + +patSigErr ty + = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty) + $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it")) + +dupFieldErr str dup + = hsep [ptext SLIT("duplicate field name"), + quotes (ppr dup), + ptext SLIT("in record"), text str] +\end{code} diff --git a/compiler/rename/rename.tex b/compiler/rename/rename.tex new file mode 100644 index 0000000000..b3f8e1d770 --- /dev/null +++ b/compiler/rename/rename.tex @@ -0,0 +1,18 @@ +\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} |