X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnPat.lhs;h=844a1f90c24d1dbc0c725c91a8d86e78af97c2b3;hp=813f39b8a1f06d73a2ba93f32ee2e43ca1050708;hb=c5b178be60a5a44abd2f4ddf8c399857678326e2;hpb=f1cc3eb980a634e62f2739a7a25387c902fa9d8a diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 813f39b..844a1f9 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -40,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 @@ -135,15 +135,14 @@ data NameMaker | 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 + 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 :: HsMatchContext a -> NameMaker matchNameMaker ctxt = LamMk report_unused @@ -162,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; @@ -178,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. %********************************************************* %* * @@ -236,7 +245,7 @@ rnPat :: HsMatchContext Name -- for error messages -> RnM (a, FreeVars) -- Variables bound by pattern do not -- appear in the result FreeVars rnPat ctxt pat thing_inside - = rnPats ctxt [pat] (\[pat'] -> thing_inside pat') + = 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 } @@ -290,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) @@ -302,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 } @@ -333,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 @@ -358,10 +367,6 @@ 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) @@ -444,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 @@ -481,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