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,
mapFvRn, mapFvRnCPS,
warnUnusedMatches, warnUnusedModules, warnUnusedImports,
warnUnusedTopBinds, warnUnusedLocalBinds,
- dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg,
-
- checkM
+ dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg
) where
#include "HsVersions.h"
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
-- 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}
%*********************************************************
-- 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
--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
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
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) }
-----------------------------------------------
-- 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,
; 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)
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)
; 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
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
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
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
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
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}
%*********************************************************
\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 ()
---------------------
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) }
-------------------------------------
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]
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
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)
-> 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
-> 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
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"
\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;
\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)
= 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
\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,
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}
, 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}
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
= (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 '\''
badViewPat :: Pat RdrName -> SDoc
badViewPat pat = vcat [ptext (sLit "Illegal view pattern: ") <+> ppr pat,
ptext (sLit "Use -XViewPatterns to enable view patterns")]
-
\end{code}
projects / ghc-hetmet.git / commitdiff