X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnPat.lhs;h=844a1f90c24d1dbc0c725c91a8d86e78af97c2b3;hp=63672553501c4ccd7f83d57c5766b942076264b7;hb=2d4d636af091b8da27466b5cf90011395a9c2f66;hpb=df8b00e014ad8280354dd3fab6e6df0a52377627 diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 6367255..844a1f9 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -11,7 +11,7 @@ free variables. \begin{code} module RnPat (-- main entry points - rnPats, rnBindPat, + rnPat, rnPats, rnBindPat, NameMaker, applyNameMaker, -- a utility for making names: localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names, @@ -22,9 +22,6 @@ module RnPat (-- main entry points -- Literals rnLit, rnOverLit, - -- Quasiquotation - rnQuasiQuote, - -- Pattern Error messages that are also used elsewhere checkTupSize, patSigErr ) where @@ -43,13 +40,13 @@ import TcRnMonad import TcHsSyn ( hsOverLitName ) import RnEnv import RnTypes -import DynFlags ( DynFlag(..) ) +import DynFlags import PrelNames import Constants ( mAX_TUPLE_SIZE ) import Name import NameSet -import Module import RdrName +import BasicTypes import ListSetOps ( removeDups, minusList ) import Outputable import SrcLoc @@ -133,21 +130,28 @@ which is how you go from a RdrName to a Name data NameMaker = LamMk -- Lambdas Bool -- True <=> report unused bindings + -- (even if True, the warning only comes out + -- if -fwarn-unused-matches is on) | LetMk -- Let bindings, incl top level - -- Do not check for unused bindings - (Maybe Module) -- Just m => top level of module m - -- Nothing => not top level + -- Do *not* check for unused bindings + TopLevelFlag MiniFixityEnv -topRecNameMaker :: Module -> MiniFixityEnv -> NameMaker -topRecNameMaker mod fix_env = LetMk (Just mod) fix_env +topRecNameMaker :: MiniFixityEnv -> NameMaker +topRecNameMaker fix_env = LetMk TopLevel fix_env localRecNameMaker :: MiniFixityEnv -> NameMaker -localRecNameMaker fix_env = LetMk Nothing fix_env +localRecNameMaker fix_env = LetMk NotTopLevel fix_env -matchNameMaker :: NameMaker -matchNameMaker = LamMk True +matchNameMaker :: HsMatchContext a -> NameMaker +matchNameMaker ctxt = LamMk report_unused + where + -- Do not report unused names in interactive contexts + -- i.e. when you type 'x <- e' at the GHCi prompt + report_unused = case ctxt of + StmtCtxt GhciStmt -> False + _ -> True newName :: NameMaker -> Located RdrName -> CpsRn Name newName (LamMk report_unused) rdr_name @@ -157,15 +161,17 @@ newName (LamMk report_unused) rdr_name ; when report_unused $ warnUnusedMatches [name] fvs ; return (res, name `delFV` fvs) }) -newName (LetMk mb_top fix_env) rdr_name +newName (LetMk is_top fix_env) rdr_name = CpsRn (\ thing_inside -> - do { name <- case mb_top of - Nothing -> newLocalBndrRn rdr_name - Just mod -> newTopSrcBinder mod rdr_name - ; bindLocalNamesFV_WithFixities [name] fix_env $ + do { name <- case is_top of + NotTopLevel -> newLocalBndrRn rdr_name + TopLevel -> newTopSrcBinder rdr_name + ; bindLocalName name $ -- Do *not* use bindLocalNameFV here + -- See Note [View pattern usage] + addLocalFixities fix_env [name] $ thing_inside name }) - -- Note: the bindLocalNamesFV_WithFixities is somewhat suspicious + -- Note: the bindLocalName is somewhat suspicious -- because it binds a top-level name as a local name. -- however, this binding seems to work, and it only exists for -- the duration of the patterns and the continuation; @@ -173,6 +179,14 @@ newName (LetMk mb_top fix_env) rdr_name -- before going on to the RHSes (see RnSource.lhs). \end{code} +Note [View pattern usage] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + let (r, (r -> x)) = x in ... +Here the pattern binds 'r', and then uses it *only* in the view pattern. +We want to "see" this use, and in let-bindings we collect all uses and +report unused variables at the binding level. So we must use bindLocalName +here, *not* bindLocalNameFV. Trac #3943. %********************************************************* %* * @@ -212,8 +226,8 @@ rnPats ctxt pats thing_inside -- (0) bring into scope all of the type variables bound by the patterns -- (1) rename the patterns, bringing into scope all of the term variables -- (2) then do the thing inside. - ; bindPatSigTyVarsFV (collectSigTysFromPats pats) $ - unCpsRn (rnLPatsAndThen matchNameMaker pats) $ \ pats' -> do + ; bindPatSigTyVarsFV (collectSigTysFromPats pats) $ + unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do { -- Check for duplicated and shadowed names -- Because we don't bind the vars all at once, we can't -- check incrementally for duplicates; @@ -225,6 +239,13 @@ rnPats ctxt pats thing_inside where doc_pat = ptext (sLit "In") <+> pprMatchContext ctxt +rnPat :: HsMatchContext Name -- for error messages + -> LPat RdrName + -> (LPat Name -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) -- Variables bound by pattern do not + -- appear in the result FreeVars +rnPat ctxt pat thing_inside + = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat') applyNameMaker :: NameMaker -> Located RdrName -> RnM Name applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newName mk rdr); return n } @@ -278,7 +299,7 @@ rnPatAndThen mk (VarPat rdr) = do { loc <- liftCps getSrcSpanM -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) rnPatAndThen mk (SigPatIn pat ty) - = do { patsigs <- liftCps (doptM Opt_ScopedTypeVariables) + = do { patsigs <- liftCps (xoptM Opt_ScopedTypeVariables) ; if patsigs then do { pat' <- rnLPatAndThen mk pat ; ty' <- liftCpsFV (rnHsTypeFVs tvdoc ty) @@ -290,7 +311,7 @@ rnPatAndThen mk (SigPatIn pat ty) rnPatAndThen mk (LitPat lit) | HsString s <- lit - = do { ovlStr <- liftCps (doptM Opt_OverloadedStrings) + = do { ovlStr <- liftCps (xoptM Opt_OverloadedStrings) ; if ovlStr then rnPatAndThen mk (mkNPat (mkHsIsString s placeHolderType) Nothing) else normal_lit } @@ -321,7 +342,7 @@ rnPatAndThen mk (AsPat rdr pat) ; return (AsPat (L (nameSrcSpan new_name) new_name) pat') } rnPatAndThen mk p@(ViewPat expr pat ty) - = do { liftCps $ do { vp_flag <- doptM Opt_ViewPatterns + = do { liftCps $ do { vp_flag <- xoptM Opt_ViewPatterns ; checkErr vp_flag (badViewPat p) } -- Because of the way we're arranging the recursive calls, -- this will be in the right context @@ -346,17 +367,12 @@ rnPatAndThen mk (TuplePat pats boxed _) ; pats' <- rnLPatsAndThen mk pats ; return (TuplePat pats' boxed placeHolderType) } -rnPatAndThen _ (TypePat ty) - = do { ty' <- liftCpsFV $ rnHsTypeFVs (text "In a type pattern") ty - ; return (TypePat ty') } - #ifndef GHCI rnPatAndThen _ p@(QuasiQuotePat {}) = pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p) #else rnPatAndThen mk (QuasiQuotePat qq) - = do { qq' <- liftCpsFV $ rnQuasiQuote qq - ; pat <- liftCps $ runQuasiQuotePat qq' + = do { pat <- liftCps $ runQuasiQuotePat qq ; L _ pat' <- rnLPatAndThen mk pat ; return pat' } #endif /* GHCI */ @@ -433,8 +449,8 @@ rnHsRecFields1 -- of each x=e binding rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) - = do { pun_ok <- doptM Opt_RecordPuns - ; disambig_ok <- doptM Opt_DisambiguateRecordFields + = do { pun_ok <- xoptM Opt_RecordPuns + ; disambig_ok <- xoptM Opt_DisambiguateRecordFields ; parent <- check_disambiguation disambig_ok mb_con ; flds1 <- mapM (rn_fld pun_ok parent) flds ; mapM_ (addErr . dupFieldErr ctxt) dup_flds @@ -470,7 +486,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot } rn_dotdot (Just n) (Just con) flds -- ".." on record con/pat = ASSERT( n == length flds ) do { loc <- getSrcSpanM -- Rather approximate - ; dd_flag <- doptM Opt_RecordWildCards + ; dd_flag <- xoptM Opt_RecordWildCards ; checkErr dd_flag (needFlagDotDot ctxt) ; con_fields <- lookupConstructorFields con @@ -557,27 +573,6 @@ rnOverLit lit@(OverLit {ol_val=val}) %************************************************************************ %* * -\subsubsection{Quasiquotation} -%* * -%************************************************************************ - -See Note [Quasi-quote overview] in TcSplice. - -\begin{code} -rnQuasiQuote :: HsQuasiQuote RdrName -> RnM (HsQuasiQuote Name, FreeVars) -rnQuasiQuote (HsQuasiQuote n quoter quoteSpan quote) - = do { loc <- getSrcSpanM - ; n' <- newLocalBndrRn (L loc n) - ; quoter' <- lookupOccRn quoter - -- If 'quoter' is not in scope, proceed no further - -- Otherwise lookupOcc adds an error messsage and returns - -- an "unubound name", which makes the subsequent attempt to - -- run the quote fail - ; return (HsQuasiQuote n' quoter' quoteSpan quote, unitFV quoter') } -\end{code} - -%************************************************************************ -%* * \subsubsection{Errors} %* * %************************************************************************