\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,
-- Literals
rnLit, rnOverLit,
- -- Quasiquotation
- rnQuasiQuote,
-
-- Pattern Error messages that are also used elsewhere
checkTupSize, patSigErr
) where
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
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
; 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;
-- 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.
%*********************************************************
%* *
-- (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;
-- Nor can we check incrementally for shadowing, else we'll
-- complain *twice* about duplicates e.g. f (x,x) = ...
; let names = collectPatsBinders pats'
- ; checkDupNames doc_pat names
- ; checkShadowedNames doc_pat envs_before
- [(nameSrcSpan name, nameOccName name) | name <- names]
+ ; addErrCtxt doc_pat $ checkDupAndShadowedNames envs_before names
; thing_inside pats' } }
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 }
-- (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)
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 }
; 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
; 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 */
-- 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
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
extras = [ HsRecField
{ hsRecFieldId = L loc f
, hsRecFieldArg = name_to_arg (L loc f)
- , hsRecPun = True }
+ , hsRecPun = False }
| f <- absent_flds ]
; return (flds ++ extras) }
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
projects / ghc-hetmet.git / blobdiff