Haddock fix in the vectoriser

[ghc-hetmet.git] / compiler / rename / RnPat.lhs

diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index 813f39b..844a1f9 100644 (file)
--- 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