Improvements to record puns, wildcards
authorsimonpj@microsoft.com <unknown>
Thu, 20 Aug 2009 12:34:43 +0000 (12:34 +0000)
committersimonpj@microsoft.com <unknown>
Thu, 20 Aug 2009 12:34:43 +0000 (12:34 +0000)
* Make C { A.a } work with punning, expanding to C { A.a = a }

* Make it so that, with -fwarn-unused-matches,
        f (C {..}) = x
  does not complain about the bindings introduced by the "..".

* Make -XRecordWildCards implies -XDisambiguateRecordFields.

* Overall refactoring of RnPat, which had become very crufty.
  In particular, there is now a monad, CpsRn, private to RnPat,
  which deals with the cps-style plumbing.  This is why so many
  lines of RnPat have changed.

* Refactor the treatment of renaming of record fields into two passes
- rnHsRecFields1, used both for patterns and expressions,
     which expands puns, wild-cards
   - a local renamer in RnPat for fields in patterns
- a local renamer in RnExpr for fields in construction and update
  This make it all MUCH easier to understand

* Improve documentation of record puns, wildcards, and disambiguation

12 files changed:
compiler/basicTypes/RdrName.lhs
compiler/main/DynFlags.hs
compiler/parser/RdrHsSyn.lhs
compiler/rename/RnBinds.lhs
compiler/rename/RnEnv.lhs
compiler/rename/RnExpr.lhs
compiler/rename/RnPat.lhs
compiler/rename/RnSource.lhs
compiler/rename/RnTypes.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcPat.lhs
docs/users_guide/glasgow_exts.xml

index d476f4a..ed6bd43 100644 (file)
@@ -40,7 +40,7 @@ module RdrName (
        showRdrName,
 
        -- * Local mapping of 'RdrName' to 'Name.Name'
-       LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv,
+       LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList,
        lookupLocalRdrEnv, lookupLocalRdrOcc, elemLocalRdrEnv,
 
        -- * Global mapping of 'RdrName' to 'GlobalRdrElt's
@@ -48,7 +48,7 @@ module RdrName (
        lookupGlobalRdrEnv, extendGlobalRdrEnv,
        pprGlobalRdrEnv, globalRdrEnvElts,
        lookupGRE_RdrName, lookupGRE_Name, getGRE_NameQualifier_maybes,
-        hideSomeUnquals, findLocalDupsRdrEnv,
+        hideSomeUnquals, findLocalDupsRdrEnv, pickGREs,
 
        -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'
        GlobalRdrElt(..), isLocalGRE, unQualOK, qualSpecOK, unQualSpecOK,
@@ -316,8 +316,12 @@ type LocalRdrEnv = OccEnv Name
 emptyLocalRdrEnv :: LocalRdrEnv
 emptyLocalRdrEnv = emptyOccEnv
 
-extendLocalRdrEnv :: LocalRdrEnv -> [Name] -> LocalRdrEnv
-extendLocalRdrEnv env names
+extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv
+extendLocalRdrEnv env name
+  = extendOccEnv env (nameOccName name) name
+
+extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv
+extendLocalRdrEnvList env names
   = extendOccEnvList env [(nameOccName n, n) | n <- names]
 
 lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
@@ -474,7 +478,7 @@ pickGREs rdr_name gres
     pick :: GlobalRdrElt -> Maybe GlobalRdrElt
     pick gre@(GRE {gre_prov = LocalDef, gre_name = n})         -- Local def
        | rdr_is_unqual                    = Just gre
-       | Just (mod,_) <- rdr_is_qual           -- Qualified name
+       | Just (mod,_) <- rdr_is_qual        -- Qualified name
        , Just n_mod <- nameModule_maybe n   -- Binder is External
        , mod == moduleName n_mod          = Just gre
        | otherwise                        = Nothing
index b0d4300..1969c3b 100644 (file)
@@ -1856,6 +1856,12 @@ impliedFlags
     , (Opt_ScopedTypeVariables, Opt_RelaxedPolyRec)  -- Ditto for scoped type variables; see
                                                      --      Note [Scoped tyvars] in TcBinds
     , (Opt_ImpredicativeTypes,  Opt_RankNTypes)
+
+       -- Record wild-cards implies field disambiguation
+       -- Otherwise if you write (C {..}) you may well get
+       -- stuff like " 'a' not in scope ", which is a bit silly
+       -- if the compiler has just filled in field 'a' of constructor 'C'
+    , (Opt_RecordWildCards,     Opt_DisambiguateRecordFields)
   ]
 
 glasgowExtsFlags :: [DynFlag]
index 5d54c2f..59dfe02 100644 (file)
@@ -53,8 +53,7 @@ import HsSyn          -- Lots of it
 import Class            ( FunDep )
 import TypeRep          ( Kind )
 import RdrName         ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, 
-                         isRdrDataCon, isUnqual, getRdrName, isQual,
-                         setRdrNameSpace, showRdrName )
+                         isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace )
 import BasicTypes      ( maxPrecedence, Activation, RuleMatchInfo,
                           InlinePragma(..),  InlineSpec(..),
                           alwaysInlineSpec, neverInlineSpec )
@@ -728,11 +727,9 @@ checkPat loc _ _
 
 checkAPat :: DynFlags -> SrcSpan -> HsExpr RdrName -> P (Pat RdrName)
 checkAPat dynflags loc e = case e of
-   EWildPat           -> return (WildPat placeHolderType)
-   HsVar x | isQual x  -> parseError loc ("Qualified variable in pattern: "
-                                        ++ showRdrName x)
-          | otherwise -> return (VarPat x)
-   HsLit l            -> return (LitPat l)
+   EWildPat -> return (WildPat placeHolderType)
+   HsVar x  -> return (VarPat x)
+   HsLit l  -> return (LitPat l)
 
    -- Overloaded numeric patterns (e.g. f 0 x = x)
    -- Negation is recorded separately, so that the literal is zero or +ve
@@ -831,10 +828,6 @@ checkFunBind :: SrcSpan
              -> Located (GRHSs RdrName)
              -> P (HsBind RdrName)
 checkFunBind lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
-  | isQual (unLoc fun)
-  = parseErrorSDoc (getLoc fun) 
-       (ptext (sLit "Qualified name in function definition:") <+> ppr (unLoc fun))
-  | otherwise
   = do ps <- checkPatterns pats
        let match_span = combineSrcSpans lhs_loc rhs_span
        return (makeFunBind fun is_infix [L match_span (Match ps opt_sig grhss)])
index d7865f4..2f80afc 100644 (file)
@@ -23,7 +23,7 @@ import RdrHsSyn
 import RnHsSyn
 import TcRnMonad
 import RnTypes        ( rnHsSigType, rnLHsType, checkPrecMatch)
-import RnPat          (rnPatsAndThen_LocalRightwards, rnBindPat,
+import RnPat          (rnPats, rnBindPat,
                        NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker
                       )
                       
@@ -157,8 +157,10 @@ it expects the global environment to contain bindings for the binders
 rnTopBindsLHS :: MiniFixityEnv
               -> HsValBinds RdrName 
               -> RnM (HsValBindsLR Name RdrName)
-rnTopBindsLHS fix_env binds = 
-    (uncurry $ rnValBindsLHSFromDoc (topRecNameMaker fix_env)) (bindersAndDoc binds) binds
+rnTopBindsLHS fix_env binds
+  = do { let (boundNames,doc) = bindersAndDoc binds 
+       ; mod <- getModule
+       ; rnValBindsLHSFromDoc (topRecNameMaker mod fix_env) boundNames doc binds }
 
 rnTopBindsRHS :: NameSet       -- Names bound by these binds
               -> HsValBindsLR Name RdrName 
@@ -461,8 +463,7 @@ rnBindLHS name_maker _ (L loc (FunBind { fun_id = name@(L nameLoc _),
                                          fun_tick = fun_tick
                                        }))
   = setSrcSpan loc $ 
-    do { (newname, _fvs) <- applyNameMaker name_maker name $ \ newname ->
-                           return (newname, emptyFVs) 
+    do { newname <- applyNameMaker name_maker name
        ; return (L loc (FunBind { fun_id = L nameLoc newname, 
                                  fun_infix = inf, 
                                  fun_matches = matches,
@@ -769,7 +770,7 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
 
               -- Now the main event
               -- note that there are no local ficity decls for matches
-       ; rnPatsAndThen_LocalRightwards ctxt pats       $ \ pats' -> do
+       ; rnPats ctxt pats      $ \ pats' -> do
        { (grhss', grhss_fvs) <- rnGRHSs ctxt grhss
 
        ; return (Match pats' Nothing grhss', grhss_fvs) }}
index 414a717..d3e1bdc 100644 (file)
@@ -12,13 +12,13 @@ module RnEnv (
        lookupGlobalOccRn, lookupGlobalOccRn_maybe,
        lookupLocalDataTcNames, lookupSigOccRn,
        lookupFixityRn, lookupTyFixityRn, 
-       lookupInstDeclBndr, lookupRecordBndr, lookupConstructorFields,
+       lookupInstDeclBndr, lookupLocatedSubBndr, lookupConstructorFields,
        lookupSyntaxName, lookupSyntaxTable, 
        lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe,
        getLookupOccRn, addUsedRdrNames,
 
-       newLocalsRn, newIPNameRn,
-       bindLocalNames, bindLocalNamesFV, 
+       newLocalBndrRn, newLocalBndrsRn, newIPNameRn,
+       bindLocalName, bindLocalNames, bindLocalNamesFV, 
        MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv,
        bindLocalNamesFV_WithFixities,
        bindLocatedLocalsFV, bindLocatedLocalsRn,
@@ -30,9 +30,7 @@ module RnEnv (
        mapFvRn, mapFvRnCPS,
        warnUnusedMatches, warnUnusedModules, warnUnusedImports, 
        warnUnusedTopBinds, warnUnusedLocalBinds,
-       dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg,
-
-       checkM
+       dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg
     ) where
 
 #include "HsVersions.h"
@@ -55,8 +53,8 @@ import DataCon                ( dataConFieldLabels )
 import OccName
 import Module          ( Module, ModuleName )
 import PrelNames       ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, 
-                         consDataConKey, hasKey, forall_tv_RDR )
-import UniqSupply
+                         consDataConKey, forall_tv_RDR )
+import Unique
 import BasicTypes
 import ErrUtils                ( Message )
 import SrcLoc
@@ -75,21 +73,6 @@ import qualified Data.Set as Set
 -- XXX
 thenM :: Monad a => a b -> (b -> a c) -> a c
 thenM = (>>=)
-
-thenM_ :: Monad a => a b -> a c -> a c
-thenM_ = (>>)
-
-returnM :: Monad m => a -> m a
-returnM = return
-
-mappM :: (Monad m) => (a -> m b) -> [a] -> m [b]
-mappM = mapM
-
-mappM_ :: (Monad m) => (a -> m b) -> [a] -> m ()
-mappM_ = mapM_
-
-checkM :: Monad m => Bool -> m () -> m ()
-checkM = unless
 \end{code}
 
 %*********************************************************
@@ -112,13 +95,13 @@ newTopSrcBinder this_mod (L loc rdr_name)
        --      data T = (,) Int Int
        -- unless we are in GHC.Tup
     ASSERT2( isExternalName name,  ppr name )
-    do { checkM (this_mod == nameModule name)
+    do { unless (this_mod == nameModule name)
                 (addErrAt loc (badOrigBinding rdr_name))
        ; return name }
 
 
   | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-  = do { checkM (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
+  = do { unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
                 (addErrAt loc (badOrigBinding rdr_name))
        -- When reading External Core we get Orig names as binders, 
        -- but they should agree with the module gotten from the monad
@@ -141,7 +124,7 @@ newTopSrcBinder this_mod (L loc rdr_name)
                --TODO, should pass the whole span
 
   | otherwise
-  = do { checkM (not (isQual rdr_name))
+  = do { unless (not (isQual rdr_name))
                 (addErrAt loc (badQualBndrErr rdr_name))
                -- Binders should not be qualified; if they are, and with a different
                -- module name, we we get a confusing "M.T is not in scope" error later
@@ -207,7 +190,7 @@ lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name)
 
 lookupTopBndrRn_maybe rdr_name
   | Just name <- isExact_maybe rdr_name
-  = returnM (Just name)
+  = return (Just name)
 
   | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name   
        -- This deals with the case of derived bindings, where
@@ -223,12 +206,12 @@ lookupTopBndrRn_maybe rdr_name
           let occ = rdrNameOcc rdr_name
         ; when (isTcOcc occ && isSymOcc occ)
                (do { op_ok <- doptM Opt_TypeOperators
-                  ; checkM op_ok (addErr (opDeclErr rdr_name)) })
+                  ; unless op_ok (addErr (opDeclErr rdr_name)) })
 
        ; mb_gre <- lookupGreLocalRn rdr_name
        ; case mb_gre of
-               Nothing  -> returnM Nothing
-               Just gre -> returnM (Just $ gre_name gre) }
+               Nothing  -> return Nothing
+               Just gre -> return (Just $ gre_name gre) }
              
 
 -----------------------------------------------
@@ -244,40 +227,11 @@ lookupInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name)
 -- name is only in scope qualified.  I.e. even if method op is
 -- in scope as M.op, we still allow plain 'op' on the LHS of
 -- an instance decl
-lookupInstDeclBndr cls rdr = lookup_located_sub_bndr is_op doc rdr
+lookupInstDeclBndr cls rdr = lookupLocatedSubBndr (ParentIs cls) doc rdr
   where
     doc = ptext (sLit "method of class") <+> quotes (ppr cls)
-    is_op (GRE {gre_par = ParentIs n}) = n == cls
-    is_op _                            = False
 
 -----------------------------------------------
-lookupRecordBndr :: Maybe (Located Name) -> Located RdrName -> RnM (Located Name)
--- Used for record construction and pattern matching
--- When the -XDisambiguateRecordFields flag is on, take account of the
--- constructor name to disambiguate which field to use; it's just the
--- same as for instance decls
--- 
--- NB: Consider this:
---     module Foo where { data R = R { fld :: Int } }
---     module Odd where { import Foo; fld x = x { fld = 3 } }
--- Arguably this should work, because the reference to 'fld' is
--- unambiguous because there is only one field id 'fld' in scope.
--- But currently it's rejected.
-lookupRecordBndr Nothing rdr_name
-  = lookupLocatedGlobalOccRn rdr_name
-lookupRecordBndr (Just (L _ data_con)) rdr_name
-  = do         { flag_on <- doptM Opt_DisambiguateRecordFields
-       ; if not flag_on 
-          then lookupLocatedGlobalOccRn rdr_name
-         else do {
-         fields <- lookupConstructorFields data_con
-       ; let is_field gre = gre_name gre `elem` fields
-       ; lookup_located_sub_bndr is_field doc rdr_name
-       }}
-   where
-     doc = ptext (sLit "field of constructor") <+> quotes (ppr data_con)
-
-
 lookupConstructorFields :: Name -> RnM [Name]
 -- Look up the fields of a given constructor
 --   * For constructors from this module, use the record field env,
@@ -298,34 +252,57 @@ lookupConstructorFields con_name
             ; return (dataConFieldLabels con) } }
 
 -----------------------------------------------
-lookup_located_sub_bndr :: (GlobalRdrElt -> Bool)
+-- Used for record construction and pattern matching
+-- When the -XDisambiguateRecordFields flag is on, take account of the
+-- constructor name to disambiguate which field to use; it's just the
+-- same as for instance decls
+-- 
+-- NB: Consider this:
+--     module Foo where { data R = R { fld :: Int } }
+--     module Odd where { import Foo; fld x = x { fld = 3 } }
+-- Arguably this should work, because the reference to 'fld' is
+-- unambiguous because there is only one field id 'fld' in scope.
+-- But currently it's rejected.
+
+lookupLocatedSubBndr :: Parent  -- NoParent   => just look it up as usual
+                                  -- ParentIs p => use p to disambiguate
                        -> SDoc -> Located RdrName
                        -> RnM (Located Name)
-lookup_located_sub_bndr is_good doc rdr_name
-  = wrapLocM (lookup_sub_bndr is_good doc) rdr_name
-
-lookup_sub_bndr :: (GlobalRdrElt -> Bool) -> SDoc -> RdrName -> RnM Name
-lookup_sub_bndr is_good doc rdr_name
-  | isUnqual rdr_name  -- Find all the things the rdr-name maps to
-  = do {               -- and pick the one with the right parent name
-        ; addUsedRdrName rdr_name
+lookupLocatedSubBndr parent doc rdr_name
+  = wrapLocM (lookup_sub_bndr parent doc) rdr_name
+
+lookup_sub_bndr :: Parent -> SDoc -> RdrName -> RnM Name
+lookup_sub_bndr parent doc rdr_name
+  | Just n <- isExact_maybe rdr_name   -- This happens in derived code
+  = return n
+
+  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+  = lookupOrig rdr_mod rdr_occ
+
+  | otherwise  -- Find all the things the rdr-name maps to
+  = do {       -- and pick the one with the right parent name
        ; env <- getGlobalRdrEnv
-       ; case filter is_good (lookupGlobalRdrEnv env (rdrNameOcc rdr_name)) of
+        ; let gres = (lookupGlobalRdrEnv env (rdrNameOcc rdr_name))
+       ; case pick parent gres  of
                -- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName!
                --     The latter does pickGREs, but we want to allow 'x'
                --     even if only 'M.x' is in scope
-           [gre] -> return (gre_name gre)
+           [gre] -> do { addUsedRdrName gre rdr_name
+                        ; return (gre_name gre) }
            []    -> do { addErr (unknownSubordinateErr doc rdr_name)
-                       ; traceRn (text "RnEnv.lookup_sub_bndr" <+> ppr rdr_name)
+                       ; traceRn (text "RnEnv.lookup_sub_bndr" <+> (ppr rdr_name $$ ppr gres))
                        ; return (mkUnboundName rdr_name) }
            gres  -> do { addNameClashErrRn rdr_name gres
-                       ; return (gre_name (head gres)) }
-       }
+                       ; return (gre_name (head gres)) } }
+  where
+    pick NoParent gres         -- Normal lookup 
+      = pickGREs rdr_name gres
+    pick (ParentIs p) gres     -- Disambiguating lookup
+      | isUnqual rdr_name = filter (right_parent p) gres
+      | otherwise         = filter (right_parent p) (pickGREs rdr_name gres)
 
-  | otherwise  -- Occurs in derived instances, where we just
-               -- refer directly to the right method with an Orig
-               -- And record fields can be Quals: C { F.f = x }
-  = lookupGlobalOccRn rdr_name
+    right_parent p (GRE { gre_par = ParentIs p' }) = p==p' 
+    right_parent _ _                               = False
 
 newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
 newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
@@ -360,7 +337,7 @@ lookupOccRn :: RdrName -> RnM Name
 lookupOccRn rdr_name
   = getLocalRdrEnv                     `thenM` \ local_env ->
     case lookupLocalRdrEnv local_env rdr_name of
-         Just name -> returnM name
+         Just name -> return name
          Nothing   -> lookupGlobalOccRn rdr_name
 
 lookupLocatedGlobalOccRn :: Located RdrName -> RnM (Located Name)
@@ -413,7 +390,7 @@ unboundName rdr_name
        ; traceRn (vcat [unknownNameErr rdr_name, 
                         ptext (sLit "Global envt is:"),
                         nest 3 (pprGlobalRdrEnv env)])
-       ; returnM (mkUnboundName rdr_name) }
+       ; return (mkUnboundName rdr_name) }
 
 --------------------------------------------------
 --     Lookup in the Global RdrEnv of the module
@@ -422,27 +399,7 @@ unboundName rdr_name
 lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)
 -- Just look up the RdrName in the GlobalRdrEnv
 lookupGreRn_maybe rdr_name 
-  = do { mGre <- lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name)
-       ; case mGre of
-           Just gre ->
-               case gre_prov gre of
-               LocalDef   -> return ()
-               Imported _ -> addUsedRdrName rdr_name
-           Nothing ->
-               return ()
-       ; return mGre }
-
-addUsedRdrName :: RdrName -> RnM ()
-addUsedRdrName rdr
-  = do { env <- getGblEnv
-       ; updMutVar (tcg_used_rdrnames env)
-                  (\s -> Set.insert rdr s) }
-
-addUsedRdrNames :: [RdrName] -> RnM ()
-addUsedRdrNames rdrs
-  = do { env <- getGblEnv
-       ; updMutVar (tcg_used_rdrnames env)
-                  (\s -> foldr Set.insert s rdrs) }
+  = lookupGreRn_help rdr_name (lookupGRE_RdrName rdr_name)
 
 lookupGreRn :: RdrName -> RnM GlobalRdrElt
 -- If not found, add error message, and return a fake GRE
@@ -471,10 +428,28 @@ lookupGreRn_help :: RdrName                       -- Only used in error message
 lookupGreRn_help rdr_name lookup 
   = do { env <- getGlobalRdrEnv
        ; case lookup env of
-           []    -> returnM Nothing
-           [gre] -> returnM (Just gre)
+           []    -> return Nothing
+           [gre] -> do { addUsedRdrName gre rdr_name
+                        ; return (Just gre) }
            gres  -> do { addNameClashErrRn rdr_name gres
-                       ; returnM (Just (head gres)) } }
+                       ; return (Just (head gres)) } }
+
+addUsedRdrName :: GlobalRdrElt -> RdrName -> RnM ()
+-- Record usage of imported RdrNames
+addUsedRdrName gre rdr
+  | isLocalGRE gre = return ()
+  | otherwise      = do { env <- getGblEnv
+                               ; updMutVar (tcg_used_rdrnames env)
+                                   (\s -> Set.insert rdr s) }
+
+addUsedRdrNames :: [RdrName] -> RnM ()
+-- Record used sub-binders
+-- We don't check for imported-ness here, because it's inconvenient
+-- and not stritly necessary.
+addUsedRdrNames rdrs
+  = do { env <- getGblEnv
+       ; updMutVar (tcg_used_rdrnames env)
+                  (\s -> foldr Set.insert s rdrs) }
 
 ------------------------------
 --     GHCi support
@@ -715,7 +690,7 @@ lookupFixityRn name
         loadInterfaceForName doc name  `thenM` \ iface -> do {
           traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+> 
                    vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)]);
-          returnM (mi_fix_fn iface (nameOccName name))
+          return (mi_fix_fn iface (nameOccName name))
                                                            }
   where
     doc = ptext (sLit "Checking fixity for") <+> ppr name
@@ -774,9 +749,9 @@ lookupSyntaxName std_name
     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)
+    return (HsVar usr_name, unitFV usr_name)
   where
-    normal_case = returnM (HsVar std_name, emptyFVs)
+    normal_case = return (HsVar std_name, emptyFVs)
 
 lookupSyntaxTable :: [Name]                            -- Standard names
                  -> RnM (SyntaxTable Name, FreeVars)   -- See comments with HsExpr.ReboundNames
@@ -785,11 +760,11 @@ lookupSyntaxTable std_names
     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 ->
+    mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names   `thenM` \ usr_names ->
 
-    returnM (std_names `zip` map HsVar usr_names, mkFVs usr_names)
+    return (std_names `zip` map HsVar usr_names, mkFVs usr_names)
   where
-    normal_case = returnM (std_names `zip` map HsVar std_names, emptyFVs)
+    normal_case = return (std_names `zip` map HsVar std_names, emptyFVs)
 \end{code}
 
 
@@ -800,18 +775,22 @@ lookupSyntaxTable std_names
 %*********************************************************
 
 \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) loc
+newLocalBndrRn :: Located RdrName -> RnM Name
+-- Used for non-top-level binders.  These should
+-- never be qualified.
+newLocalBndrRn (L loc rdr_name)
+  | Just name <- isExact_maybe rdr_name 
+  = return name        -- This happens in code generated by Template Haskell
+               -- although I'm not sure why. Perhpas it's the call
+               -- in RnPat.newName LetMk?
+  | otherwise
+  = do { unless (isUnqual rdr_name)
+               (addErrAt loc (badQualBndrErr rdr_name))
+       ; uniq <- newUnique
+       ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }
+
+newLocalBndrsRn :: [Located RdrName] -> RnM [Name]
+newLocalBndrsRn = mapM newLocalBndrRn
 
 ---------------------
 checkDupAndShadowedRdrNames :: SDoc -> [Located RdrName] -> RnM ()
@@ -823,26 +802,32 @@ checkDupAndShadowedRdrNames doc loc_rdr_names
 
 ---------------------
 bindLocatedLocalsRn :: SDoc    -- Documentation string for error message
-                       -> [Located RdrName]
+                   -> [Located RdrName]
                    -> ([Name] -> RnM a)
                    -> RnM a
 bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
-  = checkDupAndShadowedRdrNames doc_str rdr_names_w_loc        `thenM_`
+  = do { checkDupAndShadowedRdrNames doc_str rdr_names_w_loc
 
        -- Make fresh Names and extend the environment
-    newLocalsRn rdr_names_w_loc                `thenM` \names ->
-    bindLocalNames names (enclosed_scope names)
+       ; names <- newLocalBndrsRn rdr_names_w_loc
+       ; bindLocalNames 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
+  = do { name_env <- getLocalRdrEnv
+       ; setLocalRdrEnv (extendLocalRdrEnvList name_env names)
+                       enclosed_scope }
+
+bindLocalName :: Name -> RnM a -> RnM a
+bindLocalName name enclosed_scope
+  = do { name_env <- getLocalRdrEnv
+       ; setLocalRdrEnv (extendLocalRdrEnv name_env name)
+                       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) }
+       ; return (result, delListFromNameSet fvs names) }
 
 
 -------------------------------------
@@ -853,7 +838,7 @@ bindLocatedLocalsFV :: SDoc -> [Located RdrName]
 bindLocatedLocalsFV doc rdr_names enclosed_scope
   = bindLocatedLocalsRn doc rdr_names  $ \ names ->
     enclosed_scope names               `thenM` \ (thing, fvs) ->
-    returnM (thing, delListFromNameSet fvs names)
+    return (thing, delListFromNameSet fvs names)
 
 -------------------------------------
 bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName]
@@ -863,7 +848,7 @@ bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName]
 bindTyVarsRn doc_str tyvar_names enclosed_scope
   = bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
     do { kind_sigs_ok <- doptM Opt_KindSignatures
-       ; checkM (null kinded_tyvars || kind_sigs_ok) 
+       ; unless (null kinded_tyvars || kind_sigs_ok) 
                        (mapM_ (addErr . kindSigErr) kinded_tyvars)
        ; enclosed_scope (zipWith replace tyvar_names names) }
   where 
@@ -898,7 +883,7 @@ bindPatSigTyVarsFV :: [LHsType RdrName]
 bindPatSigTyVarsFV tys thing_inside
   = bindPatSigTyVars tys       $ \ tvs ->
     thing_inside               `thenM` \ (result,fvs) ->
-    returnM (result, fvs `delListFromNameSet` tvs)
+    return (result, fvs `delListFromNameSet` tvs)
 
 bindSigTyVarsFV :: [Name]
                -> RnM (a, FreeVars)
@@ -920,7 +905,7 @@ checkDupRdrNames :: SDoc
                 -> RnM ()
 checkDupRdrNames doc_str rdr_names_w_loc
   =    -- Check for duplicated names in a binding group
-    mappM_ (dupNamesErr getLoc doc_str) dups
+    mapM_ (dupNamesErr getLoc doc_str) dups
   where
     (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc
 
@@ -929,7 +914,7 @@ checkDupNames :: SDoc
              -> RnM ()
 checkDupNames doc_str names
   =    -- Check for duplicated names in a binding group
-    mappM_ (dupNamesErr nameSrcSpan doc_str) dups
+    mapM_ (dupNamesErr nameSrcSpan doc_str) dups
   where
     (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names
 
@@ -938,7 +923,7 @@ checkShadowedNames :: SDoc -> (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)]
 checkShadowedNames doc_str (global_env,local_env) loc_rdr_names
   = ifOptM Opt_WarnNameShadowing $ 
     do { traceRn (text "shadow" <+> ppr loc_rdr_names)
-       ; mappM_ check_shadow loc_rdr_names }
+       ; mapM_ check_shadow loc_rdr_names }
   where
     check_shadow (loc, occ)
         | startsWithUnderscore occ = return () -- Do not report shadowing for "_x"
@@ -981,9 +966,9 @@ checkShadowedNames doc_str (global_env,local_env) loc_rdr_names
 \begin{code}
 -- A useful utility
 mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
-mapFvRn f xs = do stuff <- mappM f xs
+mapFvRn f xs = do stuff <- mapM f xs
                   case unzip stuff of
-                      (ys, fvs_s) -> returnM (ys, plusFVs fvs_s)
+                      (ys, fvs_s) -> return (ys, plusFVs fvs_s)
 
 -- because some of the rename functions are CPSed:
 -- maps the function across the list from left to right; 
@@ -1007,7 +992,7 @@ mapFvRnCPS f (x:xs) cont = f x                $ \ x' ->
 \begin{code}
 warnUnusedModules :: [(ModuleName,SrcSpan)] -> RnM ()
 warnUnusedModules mods
-  = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods)
+  = ifOptM Opt_WarnUnusedImports (mapM_ bleat mods)
   where
     bleat (mod,loc) = addWarnAt loc (mk_warn mod)
     mk_warn m = vcat [ptext (sLit "Module") <+> quotes (ppr m)
@@ -1041,7 +1026,7 @@ warnUnusedLocals names
  = warnUnusedBinds [(n,LocalDef) | n<-names]
 
 warnUnusedBinds :: [(Name,Provenance)] -> RnM ()
-warnUnusedBinds names  = mappM_ warnUnusedName (filter reportable names)
+warnUnusedBinds names  = mapM_ warnUnusedName (filter reportable names)
  where reportable (name,_) 
        | isWiredInName name = False    -- Don't report unused wired-in names
                                        -- Otherwise we get a zillion warnings
index beee037..4b263e2 100644 (file)
@@ -48,6 +48,7 @@ import Maybes         ( expectJust )
 import Outputable
 import SrcLoc
 import FastString
+import Control.Monad
 \end{code}
 
 
@@ -248,13 +249,13 @@ rnExpr (ExplicitTuple tup_args boxity)
 
 rnExpr (RecordCon con_id _ rbinds)
   = do { conname <- lookupLocatedOccRn con_id
-       ; (rbinds', fvRbinds) <- rnHsRecFields_Con conname rnLExpr rbinds
+       ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
        ; return (RecordCon conname noPostTcExpr rbinds', 
                  fvRbinds `addOneFV` unLoc conname) }
 
 rnExpr (RecordUpd expr rbinds _ _ _)
   = do { (expr', fvExpr) <- rnLExpr expr
-       ; (rbinds', fvRbinds) <- rnHsRecFields_Update rnLExpr rbinds
+       ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
        ; return (RecordUpd expr' rbinds' [] [] [], 
                  fvExpr `plusFV` fvRbinds) }
 
@@ -307,7 +308,7 @@ rnExpr e@(ELazyPat {}) = patSynErr e
 \begin{code}
 rnExpr (HsProc pat body)
   = newArrowScope $
-    rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ [pat'] ->
+    rnPats ProcExpr [pat] $ \ [pat'] ->
     rnCmdTop body               `thenM` \ (body',fvBody) ->
     return (HsProc pat' body', fvBody)
 
@@ -364,6 +365,26 @@ rnSection other = pprPanic "rnSection" (ppr other)
 
 %************************************************************************
 %*                                                                     *
+       Records
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
+             -> RnM (HsRecordBinds Name, FreeVars)
+rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
+  = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
+       ; (flds', fvss) <- mapAndUnzipM rn_field flds
+       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }, 
+                 fvs `plusFV` plusFVs fvss) }
+  where 
+    rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
+                      ; return (fld { hsRecFieldArg = arg' }, fvs) }
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
        Arrow commands
 %*                                                                     *
 %************************************************************************
@@ -569,7 +590,7 @@ rnArithSeq (FromThenTo expr1 expr2 expr3)
 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
 rnBracket (VarBr n) = do { name <- lookupOccRn n
                         ; this_mod <- getModule
-                        ; checkM (nameIsLocalOrFrom this_mod name) $   -- Reason: deprecation checking asumes the
+                        ; unless (nameIsLocalOrFrom this_mod name) $   -- Reason: deprecation checking asumes the
                           do { _ <- loadInterfaceForName msg name      -- home interface is loaded, and this is the
                              ; return () }                             -- only way that is going to happen
                         ; return (VarBr name, unitFV name) }
@@ -644,7 +665,7 @@ rnStmt ctxt (BindStmt pat expr _ _) thing_inside
                -- The binders do not scope over the expression
        ; (bind_op, fvs1) <- lookupSyntaxName bindMName
        ; (fail_op, fvs2) <- lookupSyntaxName failMName
-       ; rnPatsAndThen_LocalRightwards (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
+       ; rnPats (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) }}
@@ -793,7 +814,7 @@ rnParallelStmts ctxt segs thing_inside = do
     where
         go orig_lcl_env bndrs [] = do 
             let (bndrs', dups) = removeDups cmpByOcc bndrs
-                inner_env = extendLocalRdrEnv orig_lcl_env bndrs'
+                inner_env = extendLocalRdrEnvList orig_lcl_env bndrs'
             
             mapM_ dupErr dups
             (thing, fvs) <- setLocalRdrEnv inner_env thing_inside
index ac35fe5..b094628 100644 (file)
@@ -11,14 +11,13 @@ free variables.
 
 \begin{code}
 module RnPat (-- main entry points
-              rnPatsAndThen_LocalRightwards, rnBindPat,
+              rnPats, rnBindPat,
 
               NameMaker, applyNameMaker,     -- a utility for making names:
               localRecNameMaker, topRecNameMaker,  --   sometimes we want to make local names,
                                              --   sometimes we want to make top (qualified) names.
 
-              rnHsRecFields_Con, rnHsRecFields_Update, --rename record fields in a constructor
-                                                       --and in an update
+              rnHsRecFields1, HsRecFieldContext(..),
 
              -- Literals
              rnLit, rnOverLit,     
@@ -49,448 +48,489 @@ import PrelNames
 import Constants       ( mAX_TUPLE_SIZE )
 import Name
 import NameSet
+import Module
 import RdrName
 import ListSetOps      ( removeDups, minusList )
 import Outputable
 import SrcLoc
 import FastString
 import Literal         ( inCharRange )
+import Control.Monad   ( when )
 \end{code}
 
 
 %*********************************************************
 %*                                                     *
-\subsection{Patterns}
+       The CpsRn Monad
 %*                                                     *
 %*********************************************************
 
+Note [CpsRn monad]
+~~~~~~~~~~~~~~~~~~
+The CpsRn monad uses continuation-passing style to support this
+style of programming:
+
+       do { ...
+           ; ns <- bindNames rs
+           ; ...blah... }
+
+   where rs::[RdrName], ns::[Name]
+
+The idea is that '...blah...' 
+  a) sees the bindings of ns
+  b) returns the free variables it mentions
+     so that bindNames can report unused ones
+
+In particular, 
+    mapM rnPatAndThen [p1, p2, p3]
+has a *left-to-right* scoping: it makes the binders in 
+p1 scope over p2,p3.
+
 \begin{code}
--- externally abstract type of name makers,
--- which is how you go from a RdrName to a Name
-data NameMaker = NM (forall a. Located RdrName -> (Name -> RnM (a, FreeVars))
-                                              -> RnM (a, FreeVars))
+newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))
+                                            -> RnM (r, FreeVars) }
+       -- See Note [CpsRn monad]
+
+instance Monad CpsRn where
+  return x = CpsRn (\k -> k x)
+  (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))
+
+runCps :: CpsRn a -> RnM (a, FreeVars)
+runCps (CpsRn m) = m (\r -> return (r, emptyFVs))
+
+liftCps :: RnM a -> CpsRn a
+liftCps rn_thing = CpsRn (\k -> rn_thing >>= k)
+
+liftCpsFV :: RnM (a, FreeVars) -> CpsRn a
+liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing
+                                     ; (r,fvs2) <- k v
+                                     ; return (r, fvs1 `plusFV` fvs2) })
+
+wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b)
+-- Set the location, and also wrap it around the value returned
+wrapSrcSpanCps fn (L loc a)
+  = CpsRn (\k -> setSrcSpan loc $ 
+                 unCpsRn (fn a) $ \v -> 
+                 k (L loc v))
+
+lookupConCps :: Located RdrName -> CpsRn (Located Name)
+lookupConCps con_rdr 
+  = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr
+                    ; (r, fvs) <- k con_name
+                    ; return (r, fvs `plusFV` unitFV (unLoc con_name)) })
+\end{code}
 
-matchNameMaker :: NameMaker
-matchNameMaker
-  = NM (\ rdr_name thing_inside -> 
-       do { names@[name] <- newLocalsRn [rdr_name]
-          ; bindLocalNamesFV names $ do
-          { (res, fvs) <- thing_inside name
-          ; warnUnusedMatches names fvs
-          ; return (res, fvs) }})
-                         
-topRecNameMaker, localRecNameMaker
-  :: MiniFixityEnv -> NameMaker
+%*********************************************************
+%*                                                     *
+       Name makers
+%*                                                     *
+%*********************************************************
 
--- topNameMaker and localBindMaker do not check for unused binding
-localRecNameMaker fix_env
-  = NM (\ rdr_name thing_inside -> 
-       do { [name] <- newLocalsRn [rdr_name]
-          ; bindLocalNamesFV_WithFixities [name] fix_env $
-            thing_inside name })
-  
-topRecNameMaker fix_env
-  = NM (\rdr_name thing_inside -> 
-        do { mod <- getModule
-           ; name <- newTopSrcBinder mod rdr_name
+Externally abstract type of name makers,
+which is how you go from a RdrName to a Name
+
+\begin{code}
+data NameMaker 
+  = LamMk      -- Lambdas 
+      Bool     -- True <=> report unused bindings
+
+  | 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
+      MiniFixityEnv
+
+topRecNameMaker :: Module -> MiniFixityEnv -> NameMaker
+topRecNameMaker mod fix_env = LetMk (Just mod) fix_env
+
+localRecNameMaker :: MiniFixityEnv -> NameMaker
+localRecNameMaker fix_env = LetMk Nothing fix_env 
+
+matchNameMaker :: NameMaker
+matchNameMaker = LamMk True
+
+newName :: NameMaker -> Located RdrName -> CpsRn Name
+newName (LamMk report_unused) rdr_name
+  = CpsRn (\ thing_inside -> 
+       do { name <- newLocalBndrRn rdr_name
+          ; (res, fvs) <- bindLocalName name (thing_inside name)
+          ; when report_unused $ warnUnusedMatches [name] fvs
+          ; return (res, name `delFV` fvs) })
+
+newName (LetMk mb_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 $
             thing_inside name })
-               -- Note: the bindLocalNamesFV_WithFixities 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;
-               --       then the top-level name is added to the global env
-               --       before going on to the RHSes (see RnSource.lhs).
-
-applyNameMaker :: NameMaker -> Located RdrName
-              -> (Name -> RnM (a,FreeVars)) -> RnM (a, FreeVars)
-applyNameMaker (NM f) = f
-
-
--- There are various entry points to renaming patterns, depending on
---  (1) whether the names created should be top-level names or local names
---  (2) whether the scope of the names is entirely given in a continuation
---      (e.g., in a case or lambda, but not in a let or at the top-level,
---       because of the way mutually recursive bindings are handled)
---  (3) whether the a type signature in the pattern can bind 
---     lexically-scoped type variables (for unpacking existential 
---     type vars in data constructors)
---  (4) whether we do duplicate and unused variable checking
---  (5) whether there are fixity declarations associated with the names
---      bound by the patterns that need to be brought into scope with them.
---      
---  Rather than burdening the clients of this module with all of these choices,
---  we export the three points in this design space that we actually need:
-
--- entry point 1:
--- binds local names; the scope of the bindings is entirely in the thing_inside
---   allows type sigs to bind type vars
---   local namemaker
---   unused and duplicate checking
---   no fixities
-rnPatsAndThen_LocalRightwards :: HsMatchContext Name -- for error messages
-                              -> [LPat RdrName] 
-                              -- the continuation gets:
-                              --    the list of renamed patterns
-                              --    the (overall) free vars of all of them
-                              -> ([LPat Name] -> RnM (a, FreeVars))
-                              -> RnM (a, FreeVars)
-
-rnPatsAndThen_LocalRightwards ctxt pats thing_inside
+                         
+    -- Note: the bindLocalNamesFV_WithFixities 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;
+    --       then the top-level name is added to the global env
+    --       before going on to the RHSes (see RnSource.lhs).
+\end{code}
+
+
+%*********************************************************
+%*                                                     *
+       External entry points
+%*                                                     *
+%*********************************************************
+
+There are various entry points to renaming patterns, depending on
+ (1) whether the names created should be top-level names or local names
+ (2) whether the scope of the names is entirely given in a continuation
+     (e.g., in a case or lambda, but not in a let or at the top-level,
+      because of the way mutually recursive bindings are handled)
+ (3) whether the a type signature in the pattern can bind 
+       lexically-scoped type variables (for unpacking existential 
+       type vars in data constructors)
+ (4) whether we do duplicate and unused variable checking
+ (5) whether there are fixity declarations associated with the names
+     bound by the patterns that need to be brought into scope with them.
+     
+ Rather than burdening the clients of this module with all of these choices,
+ we export the three points in this design space that we actually need:
+
+\begin{code}
+-- ----------- Entry point 1: rnPats -------------------
+-- Binds local names; the scope of the bindings is entirely in the thing_inside
+--   * allows type sigs to bind type vars
+--   * local namemaker
+--   * unused and duplicate checking
+--   * no fixities
+rnPats :: HsMatchContext Name -- for error messages
+       -> [LPat RdrName] 
+       -> ([LPat Name] -> RnM (a, FreeVars))
+       -> RnM (a, FreeVars)
+rnPats ctxt pats thing_inside
   = do { envs_before <- getRdrEnvs
 
          -- (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) $ 
-         rnLPatsAndThen matchNameMaker pats    $ \ pats' ->
-            do { -- Check for duplicated and shadowed names 
+         unCpsRn (rnLPatsAndThen matchNameMaker 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]
-            ; thing_inside pats' } }
+        ; let names = collectPatsBinders pats'
+        ; checkDupNames doc_pat names
+       ; checkShadowedNames doc_pat envs_before
+                            [(nameSrcSpan name, nameOccName name) | name <- names]
+        ; thing_inside pats' } }
   where
     doc_pat = ptext (sLit "In") <+> pprMatchContext ctxt
 
 
--- entry point 2:
--- binds local names; in a recursive scope that involves other bound vars
+applyNameMaker :: NameMaker -> Located RdrName -> RnM Name
+applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newName mk rdr); return n }
+
+-- ----------- Entry point 2: rnBindPat -------------------
+-- Binds local names; in a recursive scope that involves other bound vars
 --     e.g let { (x, Just y) = e1; ... } in ...
---   does NOT allows type sig to bind type vars
---   local namemaker
---   no unused and duplicate checking
---   fixities might be coming in
+--   does NOT allows type sig to bind type vars
+--   local namemaker
+--   no unused and duplicate checking
+--   fixities might be coming in
 rnBindPat :: NameMaker
           -> LPat RdrName
-          -> RnM (LPat Name, 
-                       -- free variables of the pattern,
-                       -- but not including variables bound by this pattern 
-                   FreeVars)
-
-rnBindPat name_maker pat
-  = rnLPatsAndThen name_maker [pat] $ \ [pat'] ->
-    return (pat', emptyFVs)
-
-
--- general version: parametrized by how you make new names
--- invariant: what-to-do continuation only gets called with a list whose length is the same as
---            the part of the pattern we're currently renaming
-rnLPatsAndThen :: NameMaker -- how to make a new variable
-               -> [LPat RdrName]   -- part of pattern we're currently renaming
-               -> ([LPat Name] -> RnM (a, FreeVars)) -- what to do afterwards
-               -> RnM (a, FreeVars) -- renaming of the whole thing
-               
-rnLPatsAndThen var = mapFvRnCPS (rnLPatAndThen var)
-
-
--- the workhorse
-rnLPatAndThen :: NameMaker
-              -> LPat RdrName   -- part of pattern we're currently renaming
-              -> (LPat Name -> RnM (a, FreeVars)) -- what to do afterwards
-              -> RnM (a, FreeVars) -- renaming of the whole thing
-rnLPatAndThen var@(NM varf) (L loc p) cont = 
-    setSrcSpan loc $ 
-      let reloc = L loc 
-          lcont = \ unlocated -> cont (reloc unlocated)
-      in
-       case p of
-         WildPat _   -> lcont (WildPat placeHolderType)
-
-         ParPat pat  -> rnLPatAndThen var pat $ \ pat' -> lcont (ParPat pat')
-         LazyPat pat -> rnLPatAndThen var pat $ \ pat' -> lcont (LazyPat pat')
-         BangPat pat -> rnLPatAndThen var pat $ \ pat' -> lcont (BangPat pat')
-         
-         VarPat name -> 
-           varf (reloc name) $ \ newBoundName -> 
-           lcont (VarPat newBoundName)
-               -- we need to bind pattern variables for view pattern expressions
-               -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
+          -> RnM (LPat Name, FreeVars)
+   -- Returned FreeVars are the free variables of the pattern,
+   -- of course excluding variables bound by this pattern 
+
+rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat)
+\end{code}
+
+
+%*********************************************************
+%*                                                     *
+       The main event
+%*                                                     *
+%*********************************************************
+
+\begin{code}
+-- ----------- Entry point 3: rnLPatAndThen -------------------
+-- General version: parametrized by how you make new names
+
+rnLPatsAndThen :: NameMaker -> [LPat RdrName] -> CpsRn [LPat Name]
+rnLPatsAndThen mk = mapM (rnLPatAndThen mk)
+  -- Despite the map, the monad ensures that each pattern binds
+  -- variables that may be mentioned in subsequent patterns in the list
+
+--------------------
+-- The workhorse
+rnLPatAndThen :: NameMaker -> LPat RdrName -> CpsRn (LPat Name)
+rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat
+
+rnPatAndThen :: NameMaker -> Pat RdrName -> CpsRn (Pat Name)
+rnPatAndThen _  (WildPat _)   = return (WildPat placeHolderType)
+rnPatAndThen mk (ParPat pat)  = do { pat' <- rnLPatAndThen mk pat; return (ParPat pat') }
+rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') }
+rnPatAndThen mk (BangPat pat) = do { pat' <- rnLPatAndThen mk pat; return (BangPat pat') }
+rnPatAndThen mk (VarPat rdr)  = do { loc <- liftCps getSrcSpanM
+                                   ; name <- newName mk (L loc rdr)
+                                   ; return (VarPat name) }
+     -- we need to bind pattern variables for view pattern expressions
+     -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
                                      
-         SigPatIn pat ty -> do
-             patsigs <- doptM Opt_ScopedTypeVariables
-             if patsigs
-              then rnLPatAndThen var pat
-                      (\ pat' -> do { (ty', fvs1) <- rnHsTypeFVs tvdoc ty
-                                   ; (res, fvs2) <- lcont (SigPatIn pat' ty')
-                                   ; return (res, fvs1 `plusFV` fvs2) })
-              else do addErr (patSigErr ty)
-                      rnLPatAndThen var pat cont
-           where
-             tvdoc = text "In a pattern type-signature"
+rnPatAndThen mk (SigPatIn pat ty)
+  = do { patsigs <- liftCps (doptM Opt_ScopedTypeVariables)
+       ; if patsigs
+         then do { pat' <- rnLPatAndThen mk pat
+                 ; ty' <- liftCpsFV (rnHsTypeFVs tvdoc ty)
+                ; return (SigPatIn pat' ty') }
+         else do { liftCps (addErr (patSigErr ty))
+                 ; rnPatAndThen mk (unLoc pat) } }
+  where
+    tvdoc = text "In a pattern type-signature"
        
-         LitPat lit@(HsString s) -> 
-             do ovlStr <- doptM Opt_OverloadedStrings
-                if ovlStr 
-                 then rnLPatAndThen var (reloc $ mkNPat (mkHsIsString s placeHolderType) Nothing) cont
-                 else do { rnLit lit; lcont (LitPat lit) }   -- Same as below
-      
-         LitPat lit -> do { rnLit lit; lcont (LitPat lit) }
-
-         NPat lit mb_neg _eq ->
-           do { (lit', fvs1) <- rnOverLit lit
-             ; (mb_neg', fvs2) <- case mb_neg of
-                                    Nothing -> return (Nothing, emptyFVs)
-                                    Just _  -> do { (neg, fvs) <- lookupSyntaxName negateName
-                                                  ; return (Just neg, fvs) }
-             ; (eq', fvs3) <- lookupSyntaxName eqName
-             ; (res, fvs4) <- lcont (NPat lit' mb_neg' eq')
-             ; return (res, fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
-               -- Needed to find equality on pattern
-
-         NPlusKPat name lit _ _ ->
-          varf name $ \ new_name ->
-          do { (lit', fvs1) <- rnOverLit lit
-             ; (minus, fvs2) <- lookupSyntaxName minusName
-              ; (ge, fvs3) <- lookupSyntaxName geName
-              ; (res, fvs4) <- lcont (NPlusKPat (L (nameSrcSpan new_name) new_name) lit' ge minus)
-             ; return (res, fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
+rnPatAndThen mk (LitPat lit)
+  | HsString s <- lit
+  = do { ovlStr <- liftCps (doptM Opt_OverloadedStrings)
+       ; if ovlStr 
+         then rnPatAndThen mk (mkNPat (mkHsIsString s placeHolderType) Nothing)
+         else normal_lit }
+  | otherwise = normal_lit
+  where
+    normal_lit = do { liftCps (rnLit lit); return (LitPat lit) }
+
+rnPatAndThen _ (NPat lit mb_neg _eq)
+  = do { lit'    <- liftCpsFV $ rnOverLit lit
+       ; mb_neg' <- liftCpsFV $ case mb_neg of
+                     Nothing -> return (Nothing, emptyFVs)
+                     Just _  -> do { (neg, fvs) <- lookupSyntaxName negateName
+                                   ; return (Just neg, fvs) }
+       ; eq' <- liftCpsFV $ lookupSyntaxName eqName
+       ; return (NPat lit' mb_neg' eq') }
+
+rnPatAndThen mk (NPlusKPat rdr lit _ _)
+  = do { new_name <- newName mk rdr
+       ; lit'  <- liftCpsFV $ rnOverLit lit
+       ; minus <- liftCpsFV $ lookupSyntaxName minusName
+       ; ge    <- liftCpsFV $ lookupSyntaxName geName
+       ; return (NPlusKPat (L (nameSrcSpan new_name) new_name) lit' ge minus) }
                -- The Report says that n+k patterns must be in Integral
 
-         AsPat name pat ->
-          varf name $ \ new_name ->
-           rnLPatAndThen var pat $ \ pat' -> 
-           lcont (AsPat (L (nameSrcSpan new_name) new_name) pat')
-
-         ViewPat expr pat ty -> 
-          do { vp_flag <- doptM Opt_ViewPatterns
-              ; checkErr vp_flag (badViewPat p)
-                -- because of the way we're arranging the recursive calls,
-                -- this will be in the right context 
-              ; (expr', fv_expr) <- rnLExpr expr 
-              ; (res, fvs_res) <- rnLPatAndThen var pat $ \ pat' ->
-                                 lcont (ViewPat expr' pat' ty)
-             ; return (res, fvs_res `plusFV` fv_expr) }
+rnPatAndThen mk (AsPat rdr pat)
+  = do { new_name <- newName mk rdr
+       ; pat' <- rnLPatAndThen mk 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
+                      ; checkErr vp_flag (badViewPat p) }
+         -- Because of the way we're arranging the recursive calls,
+         -- this will be in the right context 
+       ; expr' <- liftCpsFV $ rnLExpr expr 
+       ; pat' <- rnLPatAndThen mk pat
+       ; return (ViewPat expr' pat' ty) }
+
+rnPatAndThen mk (ConPatIn con stuff)
+   -- rnConPatAndThen takes care of reconstructing the pattern
+  = rnConPatAndThen mk con stuff
+
+rnPatAndThen mk (ListPat pats _)
+  = do { pats' <- rnLPatsAndThen mk pats
+       ; return (ListPat pats' placeHolderType) }
+
+rnPatAndThen mk (PArrPat pats _)
+  = do { pats' <- rnLPatsAndThen mk pats
+       ; return (PArrPat pats' placeHolderType) }
+
+rnPatAndThen mk (TuplePat pats boxed _)
+  = do { liftCps $ checkTupSize (length pats)
+       ; 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
-         (QuasiQuotePat _) -> pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p)
+rnPatAndThen _ p@(QuasiQuotePat {}) 
+  = pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p)
 #else
-         QuasiQuotePat qq -> do
-             (qq', _) <- rnQuasiQuote qq
-             pat' <- runQuasiQuotePat qq'
-             rnLPatAndThen var pat' $ \ (L _ pat'') ->
-                 lcont pat''
+rnPatAndThen mk (QuasiQuotePat qq)
+  = do { qq' <- liftCpsFV $ rnQuasiQuote qq
+       ; pat <- liftCps $ runQuasiQuotePat qq'
+       ; L _ pat' <- rnLPatAndThen mk pat
+       ; return pat' }
 #endif         /* GHCI */
 
-         ConPatIn con stuff -> 
-             -- rnConPatAndThen takes care of reconstructing the pattern
-             rnConPatAndThen var con stuff cont
-
-         ListPat pats _ -> 
-           rnLPatsAndThen var pats $ \ patslist ->
-               lcont (ListPat patslist placeHolderType)
-
-         PArrPat pats _ -> 
-          do { (res, res_fvs) <- rnLPatsAndThen var pats $ \ patslist ->
-                                 lcont (PArrPat patslist placeHolderType)
-             ; return (res, res_fvs `plusFV` implicit_fvs) }
-           where
-             implicit_fvs = mkFVs [lengthPName, indexPName]
-
-         TuplePat pats boxed _ -> 
-           do { checkTupSize (length pats)
-              ; rnLPatsAndThen var pats $ \ patslist ->
-                lcont (TuplePat patslist boxed placeHolderType) }
-
-         TypePat ty -> 
-           do { (ty', fvs1) <- rnHsTypeFVs (text "In a type pattern") ty
-             ; (res, fvs2) <- lcont (TypePat ty')
-             ; return (res, fvs1 `plusFV` fvs2) }
-
-         p -> pprPanic "rnLPatAndThen" (ppr p)
+rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat)
 
 
--- helper for renaming constructor patterns
+--------------------
 rnConPatAndThen :: NameMaker
                 -> Located RdrName          -- the constructor
                 -> HsConPatDetails RdrName 
-                -> (LPat Name -> RnM (a, FreeVars)) -- what to do afterwards
-                -> RnM (a, FreeVars)
-
-rnConPatAndThen var (con@(L loc _)) (PrefixCon pats) cont
-  = do { con' <- lookupLocatedOccRn con
-       ; (res, res_fvs) <- rnLPatsAndThen var pats $ \ pats' ->
-                           cont (L loc $ ConPatIn con' (PrefixCon pats'))
-        ; return (res, res_fvs `addOneFV` unLoc con') }
-
-rnConPatAndThen var (con@(L loc _)) (InfixCon pat1 pat2) cont
-  = do { con' <- lookupLocatedOccRn con
-       ; (res, res_fvs) <- rnLPatAndThen var pat1 $ \ pat1' -> 
-                           rnLPatAndThen var pat2 $ \ pat2' ->
-                           do { fixity <- lookupFixityRn (unLoc con')
-                              ; pat' <- mkConOpPatRn con' fixity pat1' pat2'
-                              ; cont (L loc pat') }
-        ; return (res, res_fvs `addOneFV` unLoc con') }
-
-rnConPatAndThen var (con@(L loc _)) (RecCon rpats) cont
-  = do { con' <- lookupLocatedOccRn con
-       ; (res, res_fvs) <- rnHsRecFieldsAndThen_Pattern con' var rpats $ \ rpats' -> 
-                           cont (L loc $ ConPatIn con' (RecCon rpats'))
-        ; return (res, res_fvs `addOneFV` unLoc con') }
-
--- what kind of record expression we're doing
--- the first two tell the name of the datatype constructor in question
--- and give a way of creating a variable to fill in a ..
-data RnHsRecFieldsChoice a = Constructor (Located Name) (RdrName -> a)
-                           | Pattern  (Located Name) (RdrName -> a)
-                           | Update
-
-choiceToMessage :: RnHsRecFieldsChoice t -> String
-choiceToMessage (Constructor _ _) = "construction"
-choiceToMessage (Pattern _ _) = "pattern"
-choiceToMessage Update = "update"
-
-doDotDot :: RnHsRecFieldsChoice t -> Maybe (Located Name, RdrName -> t)
-doDotDot (Constructor a b) = Just (a,b)
-doDotDot (Pattern a b) = Just (a,b)
-doDotDot Update        = Nothing
-
-getChoiceName :: RnHsRecFieldsChoice field -> Maybe (Located Name)
-getChoiceName (Constructor n _) = Just n
-getChoiceName (Pattern n _) = Just n
-getChoiceName (Update) = Nothing
-
-
-
--- helper for renaming record patterns;
--- parameterized so that it can also be used for expressions
-rnHsRecFieldsAndThen :: RnHsRecFieldsChoice field
-                     -- how to rename the fields (CPSed)
-                     -> (Located field -> (Located field' -> RnM (c, FreeVars)) 
-                                       -> RnM (c, FreeVars)) 
-                     -- the actual fields 
-                     -> HsRecFields RdrName (Located field)  
-                     -- what to do in the scope of the field vars
-                     -> (HsRecFields Name (Located field') -> RnM (c, FreeVars)) 
-                     -> RnM (c, FreeVars)
--- Haddock comments for record fields are renamed to Nothing here
-rnHsRecFieldsAndThen choice rn_thing (HsRecFields fields dd) cont = 
-    let
-
-        -- helper to collect and report duplicate record fields
-        reportDuplicateFields doingstr fields = 
-            let 
-                -- each list represents a RdrName that occurred more than once
-                -- (the list contains all occurrences)
-                -- invariant: each list in dup_fields is non-empty
-                dup_fields :: [[RdrName]]
-                (_, dup_fields) = removeDups compare
-                                                 (map (unLoc . hsRecFieldId) fields)
-                                             
-                -- duplicate field reporting function
-                field_dup_err dup_group = addErr (dupFieldErr doingstr (head dup_group))
-            in
-              mapM_ field_dup_err dup_fields
-
-        -- helper to rename each field
-        rn_field pun_ok (HsRecField field inside pun) cont = do 
-          fieldname <- lookupRecordBndr (getChoiceName choice) field
-          checkErr (not pun || pun_ok) (badPun field)
-          (res, res_fvs) <- rn_thing inside $ \ inside' -> 
-                           cont (HsRecField fieldname inside' pun) 
-          return (res, res_fvs `addOneFV` unLoc fieldname)
-
-        -- Compute the extra fields to be filled in by the dot-dot notation
-        dot_dot_fields fs con mk_field cont = do 
-            con_fields <- lookupConstructorFields (unLoc con)
-            let missing_fields = con_fields `minusList` fs
-            loc <- getSrcSpanM -- Rather approximate
-            -- it's important that we make the RdrName fields that we morally wrote
-            -- and then rename them in the usual manner
-            -- (rather than trying to make the result of renaming directly)
-            -- because, for patterns, renaming can bind vars in the continuation
-            mapFvRnCPS rn_thing 
-             (map (L loc . mk_field . mkRdrUnqual . getOccName) missing_fields) $
-              \ rhss -> 
-                  let new_fs = [ HsRecField (L loc f) r False
-                                | (f, r) <- missing_fields `zip` rhss ]
-                  in 
-                  cont new_fs
-
-   in do
-       -- report duplicate fields
-       let doingstr = choiceToMessage choice
-       reportDuplicateFields doingstr fields
-
-       -- rename the records as written
-       -- check whether punning (implicit x=x) is allowed
-       pun_flag <- doptM Opt_RecordPuns
-       -- rename the fields
-       mapFvRnCPS (rn_field pun_flag) fields $ \ fields1 ->
-
-           -- handle ..
-           case dd of
-             Nothing -> cont (HsRecFields fields1 dd)
-             Just n  -> ASSERT( n == length fields ) do
-                          dd_flag <- doptM Opt_RecordWildCards
-                          checkErr dd_flag (needFlagDotDot doingstr)
-                          let fld_names1 = map (unLoc . hsRecFieldId) fields1
-                          case doDotDot choice of 
-                                Nothing -> do addErr (badDotDot doingstr)
-                                              -- we return a junk value here so that error reporting goes on
-                                              cont (HsRecFields fields1 dd)
-                                Just (con, mk_field) ->
-                                    dot_dot_fields fld_names1 con mk_field $
-                                      \ fields2 -> 
-                                          cont (HsRecFields (fields1 ++ fields2) dd)
-
-needFlagDotDot :: String -> SDoc
-needFlagDotDot str = vcat [ptext (sLit "Illegal `..' in record") <+> text str,
-                         ptext (sLit "Use -XRecordWildCards to permit this")]
-
-badDotDot :: String -> SDoc
-badDotDot str = ptext (sLit "You cannot use `..' in record") <+> text str
+                -> CpsRn (Pat Name)
+
+rnConPatAndThen mk con (PrefixCon pats)
+  = do { con' <- lookupConCps con
+       ; pats' <- rnLPatsAndThen mk pats
+       ; return (ConPatIn con' (PrefixCon pats')) }
+
+rnConPatAndThen mk con (InfixCon pat1 pat2)
+  = do { con' <- lookupConCps con
+       ; pat1' <- rnLPatAndThen mk pat1
+       ; pat2' <- rnLPatAndThen mk pat2
+       ; fixity <- liftCps $ lookupFixityRn (unLoc con')
+       ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' }
+
+rnConPatAndThen mk con (RecCon rpats)
+  = do { con' <- lookupConCps con
+       ; rpats' <- rnHsRecPatsAndThen mk con' rpats
+       ; return (ConPatIn con' (RecCon rpats')) }
+
+--------------------
+rnHsRecPatsAndThen :: NameMaker
+                   -> Located Name     -- Constructor
+                  -> HsRecFields RdrName (LPat RdrName)
+                  -> CpsRn (HsRecFields Name (LPat Name))
+rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd })
+  = do { flds <- liftCpsFV $ rnHsRecFields1 (HsRecFieldPat con) VarPat hs_rec_fields
+       ; flds' <- mapM rn_field (flds `zip` [1..])
+       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
+  where 
+    rn_field (fld, n') = do { arg' <- rnLPatAndThen (nested_mk dd mk n') 
+                                                    (hsRecFieldArg fld)
+                            ; return (fld { hsRecFieldArg = arg' }) }
+
+       -- Suppress unused-match reporting for fields introduced by ".."
+    nested_mk Nothing  mk                    _  = mk
+    nested_mk (Just _) mk@(LetMk {})         _  = mk
+    nested_mk (Just n) (LamMk report_unused) n' = LamMk (report_unused && (n' <= n))
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+       Record fields
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+data HsRecFieldContext 
+  = HsRecFieldCon Name
+  | HsRecFieldPat Name
+  | HsRecFieldUpd
+
+rnHsRecFields1 
+    :: HsRecFieldContext
+    -> (RdrName -> arg) -- When punning, use this to build a new field
+    -> HsRecFields RdrName (Located arg)
+    -> RnM ([HsRecField Name (Located arg)], FreeVars)
+
+-- This supprisingly complicated pass
+--   a) looks up the field name (possibly using disambiguation)
+--   b) fills in puns and dot-dot stuff
+-- When we we've finished, we've renamed the LHS, but not the RHS,
+-- 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
+       ; parent <- check_disambiguation disambig_ok mb_con
+       ; flds1 <- mapM (rn_fld pun_ok parent) flds
+       ; mapM_ (addErr . dupFieldErr ctxt) dup_flds
+       ; flds2 <- rn_dotdot dotdot mb_con flds1
+       ; return (flds2, mkFVs (getFieldIds flds2)) }
+  where
+    mb_con = case ctxt of
+               HsRecFieldUpd     -> Nothing
+               HsRecFieldCon con -> Just con
+               HsRecFieldPat con -> Just con
+    doc = case mb_con of
+            Nothing  -> ptext (sLit "constructor field name")
+            Just con -> ptext (sLit "field of constructor") <+> quotes (ppr con)
+
+    name_to_arg (L loc n) = L loc (mk_arg (mkRdrUnqual (nameOccName n)))
+
+    rn_fld pun_ok parent (HsRecField { hsRecFieldId = fld
+                                            , hsRecFieldArg = arg
+                                            , hsRecPun = pun })
+      = do { fld' <- lookupLocatedSubBndr parent doc fld
+           ; arg' <- if pun 
+                     then do { checkErr pun_ok (badPun fld)
+                             ; return (name_to_arg fld') }
+                     else return arg
+           ; return (HsRecField { hsRecFieldId = fld'
+                                , hsRecFieldArg = arg'
+                                , hsRecPun = pun }) }
+
+    rn_dotdot Nothing _mb_con flds     -- No ".." at all
+      = return flds
+    rn_dotdot (Just {}) Nothing flds   -- ".." on record update
+      = do { addErr (badDotDot ctxt); return 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
+           ; checkErr dd_flag (needFlagDotDot ctxt)
+
+           ; con_fields <- lookupConstructorFields con
+           ; let present_flds = getFieldIds flds
+                 absent_flds  = con_fields `minusList` present_flds
+                 extras = [ HsRecField
+                              { hsRecFieldId = L loc f
+                              , hsRecFieldArg = name_to_arg (L loc f)
+                              , hsRecPun = True }
+                          | f <- absent_flds ]
+
+           ; return (flds ++ extras) }
+
+    check_disambiguation :: Bool -> Maybe Name -> RnM Parent
+    -- When disambiguation is on, return the parent *type constructor*
+    -- That is, the parent of the data constructor.  That's the parent
+    -- to use for looking up record fields.
+    check_disambiguation disambig_ok mb_con
+      | disambig_ok, Just con <- mb_con
+      = do { env <- getGlobalRdrEnv
+           ; return (case lookupGRE_Name env con of
+                      [gre] -> gre_par gre
+                              gres  -> WARN( True, ppr con <+> ppr gres ) NoParent) }
+      | otherwise = return NoParent
+    dup_flds :: [[RdrName]]
+        -- Each list represents a RdrName that occurred more than once
+        -- (the list contains all occurrences)
+        -- Each list in dup_fields is non-empty
+    (_, dup_flds) = removeDups compare (getFieldIds flds)
+
+getFieldIds :: [HsRecField id arg] -> [id]
+getFieldIds flds = map (unLoc . hsRecFieldId) flds
+
+needFlagDotDot :: HsRecFieldContext -> SDoc
+needFlagDotDot ctxt = vcat [ptext (sLit "Illegal `..' in record") <+> pprRFC ctxt,
+                           ptext (sLit "Use -XRecordWildCards to permit this")]
+
+badDotDot :: HsRecFieldContext -> SDoc
+badDotDot ctxt = ptext (sLit "You cannot use `..' in a record") <+> pprRFC ctxt
 
 badPun :: Located RdrName -> SDoc
 badPun fld = vcat [ptext (sLit "Illegal use of punning for field") <+> quotes (ppr fld),
                   ptext (sLit "Use -XNamedFieldPuns to permit this")]
 
+dupFieldErr :: HsRecFieldContext -> [RdrName] -> SDoc
+dupFieldErr ctxt dups
+  = hsep [ptext (sLit "duplicate field name"), 
+          quotes (ppr (head dups)),
+         ptext (sLit "in record"), pprRFC ctxt]
 
--- wrappers
-rnHsRecFieldsAndThen_Pattern :: Located Name
-                             -> NameMaker -- new name maker
-                             -> HsRecFields RdrName (LPat RdrName)  
-                             -> (HsRecFields Name (LPat Name) -> RnM (c, FreeVars)) 
-                             -> RnM (c, FreeVars)
-rnHsRecFieldsAndThen_Pattern n var
-  = rnHsRecFieldsAndThen (Pattern n VarPat) (rnLPatAndThen var)
-
-
--- wrapper to use rnLExpr in CPS style;
--- because it does not bind any vars going forward, it does not need
--- to be written that way
-rnLExprAndThen :: (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))
-               -> LHsExpr RdrName 
-               -> (LHsExpr Name -> RnM (c, FreeVars)) 
-               -> RnM (c, FreeVars) 
-rnLExprAndThen f e cont = do { (x, fvs1) <- f e
-                            ; (res, fvs2) <- cont x
-                            ; return (res, fvs1 `plusFV` fvs2) }
-
-
--- non-CPSed because exprs don't leave anything bound
-rnHsRecFields_Con :: Located Name
-                  -> (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))
-                  -> HsRecFields RdrName (LHsExpr RdrName)  
-                  -> RnM (HsRecFields Name (LHsExpr Name), FreeVars)
-rnHsRecFields_Con n rnLExpr fields = rnHsRecFieldsAndThen (Constructor n HsVar) 
-                                     (rnLExprAndThen rnLExpr) fields $ \ res ->
-                                    return (res, emptyFVs)
-
-rnHsRecFields_Update :: (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))
-                     -> HsRecFields RdrName (LHsExpr RdrName)  
-                     -> RnM (HsRecFields Name (LHsExpr Name), FreeVars)
-rnHsRecFields_Update rnLExpr fields = rnHsRecFieldsAndThen Update
-                                      (rnLExprAndThen rnLExpr) fields $ \ res -> 
-                                     return (res, emptyFVs)
+pprRFC :: HsRecFieldContext -> SDoc
+pprRFC (HsRecFieldCon {}) = ptext (sLit "construction")
+pprRFC (HsRecFieldPat {}) = ptext (sLit "pattern")
+pprRFC (HsRecFieldUpd {}) = ptext (sLit "update")
 \end{code}
 
 
-
 %************************************************************************
 %*                                                                     *
 \subsubsection{Literals}
@@ -517,29 +557,6 @@ rnOverLit lit@(OverLit {ol_val=val})
                      , ol_rebindable = rebindable }, fvs) }
 \end{code}
 
-----------------------------------------------------------------
--- Old code returned extra free vars need in desugarer
--- but that is no longer necessary, I believe
---     if inIntRange i then
---        return (HsIntegral i from_integer_name placeHolderType, 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.]
-
--- (HsFractional i _ _) = do
---     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)
-
 %************************************************************************
 %*                                                                     *
 \subsubsection{Quasiquotation}
@@ -552,8 +569,8 @@ See Note [Quasi-quote overview] in TcSplice.
 rnQuasiQuote :: HsQuasiQuote RdrName -> RnM (HsQuasiQuote Name, FreeVars)
 rnQuasiQuote (HsQuasiQuote n quoter quoteSpan quote)
   = do { loc  <- getSrcSpanM
-       ; [n'] <- newLocalsRn [L loc n]
-       ; quoter' <-  (lookupOccRn quoter)
+       ; 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
@@ -582,12 +599,6 @@ patSigErr ty
   =  (ptext (sLit "Illegal signature in pattern:") <+> ppr ty)
        $$ nest 4 (ptext (sLit "Use -XScopedTypeVariables to permit it"))
 
-dupFieldErr :: String -> RdrName -> SDoc
-dupFieldErr str dup
-  = hsep [ptext (sLit "duplicate field name"), 
-          quotes (ppr dup),
-         ptext (sLit "in record"), text str]
-
 bogusCharError :: Char -> SDoc
 bogusCharError c
   = ptext (sLit "character literal out of range: '\\") <> char c  <> char '\''
@@ -595,5 +606,4 @@ bogusCharError c
 badViewPat :: Pat RdrName -> SDoc
 badViewPat pat = vcat [ptext (sLit "Illegal view pattern: ") <+> ppr pat,
                        ptext (sLit "Use -XViewPatterns to enable view patterns")]
-
 \end{code}
index 86873b0..bbf4938 100644 (file)
@@ -21,11 +21,10 @@ import RnBinds              ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSig
                                 makeMiniFixityEnv)
 import RnEnv           ( lookupLocalDataTcNames, lookupLocatedOccRn,
                          lookupTopBndrRn, lookupLocatedTopBndrRn,
-                         lookupOccRn, newLocalsRn, 
+                         lookupOccRn, newLocalBndrsRn, 
                          bindLocatedLocalsFV, bindPatSigTyVarsFV,
                          bindTyVarsRn, extendTyVarEnvFVRn,
-                         bindLocalNames, checkDupRdrNames, mapFvRn,
-                         checkM
+                         bindLocalNames, checkDupRdrNames, mapFvRn
                        )
 import RnNames         ( getLocalNonValBinders, extendGlobalRdrEnvRn )
 import HscTypes        ( GenAvailInfo(..), availsToNameSet )
@@ -779,7 +778,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
                -- No need to check for duplicate method signatures
                -- since that is done by RnNames.extendGlobalRdrEnvRn
                -- and the methods are already in scope
-           ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs
+           ; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs
            ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
 
   -- Haddock docs 
@@ -945,7 +944,7 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
     rn_at (tydecl@TyFamily  {}) = rnFamily tydecl lookupIdxVars
     rn_at (tydecl@TySynonym {}) = 
       do
-        checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
+        unless (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
         rnTyClDecl tydecl
     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
 
index 3086b94..61c039c 100644 (file)
@@ -159,7 +159,7 @@ rnHsType doc (HsListTy ty) = do
 
 rnHsType doc (HsKindSig ty k)
   = do { kind_sigs_ok <- doptM Opt_KindSignatures
-       ; checkM kind_sigs_ok (addErr (kindSigErr ty))
+       ; unless kind_sigs_ok (addErr (kindSigErr ty))
        ; ty' <- rnLHsType doc ty
        ; return (HsKindSig ty' k) }
 
@@ -610,7 +610,7 @@ rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
 rnSplice (HsSplice n expr)
   = do { checkTH expr "splice"
        ; loc  <- getSrcSpanM
-       ; [n'] <- newLocalsRn [L loc n]
+       ; n' <- newLocalBndrRn (L loc n)
        ; (expr', fvs) <- rnLExpr expr
 
        -- Ugh!  See Note [Splices] above
index 055fc2c..df6eac1 100644 (file)
@@ -337,7 +337,7 @@ tcExtendTyVarEnv2 binds thing_inside = do
                    tcl_tyvars = gtvs,
                    tcl_rdr = rdr_env}) <- getLclEnv
     let
-       rdr_env'   = extendLocalRdrEnv rdr_env (map fst binds)
+       rdr_env'   = extendLocalRdrEnvList rdr_env (map fst binds)
        new_tv_set = tcTyVarsOfTypes (map snd binds)
        le'        = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
 
@@ -408,7 +408,7 @@ tc_extend_local_id_env env th_lvl names_w_ids thing_inside
                                                  _        -> Wobbly})
                      | (name,id) <- names_w_ids, let id_ty = idType id]
     le'                    = extendNameEnvList (tcl_env env) extra_env
-    rdr_env'       = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
+    rdr_env'       = extendLocalRdrEnvList (tcl_rdr env) [name | (name,_) <- names_w_ids]
 \end{code}
 
 
index 5a54f8d..8c73fa9 100644 (file)
@@ -628,7 +628,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
                                                    unwrap_ty res_pat
 
          -- Add the stupid theta
-       ; addDataConStupidTheta data_con ctxt_res_tys
+       ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys
 
        ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs  
                      -- Get location from monad, not from ex_tvs
index 56735d0..4e541a6 100644 (file)
@@ -1336,7 +1336,6 @@ module Foo where
   data T = MkT { x :: Int }
   
   ok1 (MkS { x = n }) = n+1   -- Unambiguous
-
   ok2 n = MkT { x = n+1 }     -- Unambiguous
 
   bad1 k = k { x = 3 }  -- Ambiguous
@@ -1361,6 +1360,37 @@ if there are other variables in scope with the same name.
 This reduces the clutter of qualified names when you import two
 records from different modules that use the same field name.
 </para>
+<para>
+Some details:
+<itemizedlist>
+<listitem><para>
+Field disambiguation can be combined with punning (see <xref linkend="record-puns"/>). For exampe:
+<programlisting>
+module Foo where
+  import M
+  x=True
+  ok3 (MkS { x }) = x+1   -- Uses both disambiguation and punning
+</programlisting>
+</para></listitem>
+
+<listitem><para>
+With <option>-XDisambiguateRecordFields</option> you can use <emphasis>unqualifed</emphasis>
+field names even if the correponding selector is only in scope <emphasis>qualified</emphasis>
+For example, assuming the same module <literal>M</literal> as in our earlier example, this is legal:
+<programlisting>
+module Foo where
+  import qualified M    -- Note qualified
+
+  ok4 (M.MkS { x = n }) = n+1   -- Unambiguous
+</programlisting>
+Since the constructore <literal>MkS</literal> is only in scope qualified, you must
+name it <literal>M.MkS</literal>, but the field <literal>x</literal> does not need
+to be qualified even though <literal>M.x</literal> is in scope but <literal>x</literal>
+is not.  (In effect, it is qualified by the constructor.)
+</para></listitem>
+</itemizedlist>
+</para>
+
 </sect2>
 
     <!-- ===================== Record puns ===================  -->
@@ -1397,16 +1427,9 @@ a</literal> for the same name <literal>a</literal>.
 </para>
 
 <para>
-Note that puns and other patterns can be mixed in the same record:
-<programlisting>
-data C = C {a :: Int, b :: Int}
-f (C {a, b = 4}) = a
-</programlisting>
-and that puns can be used wherever record patterns occur (e.g. in
-<literal>let</literal> bindings or at the top-level).  
-</para>
-
-<para>
+Note that:
+<itemizedlist>
+<listitem><para>
 Record punning can also be used in an expression, writing, for example,
 <programlisting>
 let a = 1 in C {a}
@@ -1415,12 +1438,41 @@ instead of
 <programlisting>
 let a = 1 in C {a = a}
 </programlisting>
-
-Note that this expansion is purely syntactic, so the record pun
+The expansion is purely syntactic, so the expanded right-hand side
 expression refers to the nearest enclosing variable that is spelled the
 same as the field name.
+</para></listitem>
+
+<listitem><para>
+Puns and other patterns can be mixed in the same record:
+<programlisting>
+data C = C {a :: Int, b :: Int}
+f (C {a, b = 4}) = a
+</programlisting>
+</para></listitem>
+
+<listitem><para>
+Puns can be used wherever record patterns occur (e.g. in
+<literal>let</literal> bindings or at the top-level).  
+</para></listitem>
+
+<listitem><para>
+A pun on a qualified field name is expanded by stripping off the module qualifier.
+For example:
+<programlisting>
+f (C {M.a}) = a
+</programlisting>
+means
+<programlisting>
+f (M.C {M.a = a}) = a
+</programlisting>
+(This is useful if the field selector <literal>a</literal> for constructor <literal>M.C</literal>
+is only in scope in qualified form.)
+</para></listitem>
+</itemizedlist>
 </para>
 
+
 </sect2>
 
     <!-- ===================== Record wildcards ===================  -->
@@ -1431,6 +1483,7 @@ same as the field name.
 
 <para>
 Record wildcards are enabled by the flag <literal>-XRecordWildCards</literal>.
+This flag implies <literal>-XDisambiguateRecordFields</literal>.
 </para>
 
 <para>
@@ -1443,7 +1496,7 @@ f (C {a = 1, b = b, c = c, d = d}) = b + c + d
 </para>
 
 <para>
-Record wildcard syntax permits a (<literal>..</literal>) in a record
+Record wildcard syntax permits a "<literal>..</literal>" in a record
 pattern, where each elided field <literal>f</literal> is replaced by the
 pattern <literal>f = f</literal>.  For example, the above pattern can be
 written as
@@ -1453,7 +1506,10 @@ f (C {a = 1, ..}) = b + c + d
 </para>
 
 <para>
-Note that wildcards can be mixed with other patterns, including puns
+More details:
+<itemizedlist>
+<listitem><para>
+Wildcards can be mixed with other patterns, including puns
 (<xref linkend="record-puns"/>); for example, in a pattern <literal>C {a
 = 1, b, ..})</literal>.  Additionally, record wildcards can be used
 wherever record patterns occur, including in <literal>let</literal>
@@ -1463,24 +1519,38 @@ C {a = 1, ..} = e
 </programlisting>
 defines <literal>b</literal>, <literal>c</literal>, and
 <literal>d</literal>.
-</para>
+</para></listitem>
 
-<para>
+<listitem><para>
 Record wildcards can also be used in expressions, writing, for example,
-
 <programlisting>
 let {a = 1; b = 2; c = 3; d = 4} in C {..}
 </programlisting>
-
 in place of
-
 <programlisting>
 let {a = 1; b = 2; c = 3; d = 4} in C {a=a, b=b, c=c, d=d}
 </programlisting>
-
-Note that this expansion is purely syntactic, so the record wildcard
+The expansion is purely syntactic, so the record wildcard
 expression refers to the nearest enclosing variables that are spelled
 the same as the omitted field names.
+</para></listitem>
+
+<listitem><para>
+The "<literal>..</literal>" expands to the missing 
+<emphasis>in-scope</emphasis> record fields, where "in scope"
+includes both unqualified and qualified-only.  
+Any fields that are not in scope are not filled in.  For example
+<programlisting>
+module M where
+  data R = R { a,b,c :: Int }
+module X where
+  import qualified M( R(a,b) )
+  f a b = R { .. }
+</programlisting>
+The <literal>{..}</literal> expands to <literal>{M.a=a,M.b=b}</literal>,
+omitting <literal>c</literal> since it is not in scope at all.
+</para></listitem>
+</itemizedlist>
 </para>
 
 </sect2>