import RnHsSyn
import TcRnMonad
import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs,checkPrecMatch)
-import RnPat (rnPatsAndThen_LocalRightwards, rnPat_LocalRec, rnPat_TopRec,
- NameMaker, localNameMaker, topNameMaker, applyNameMaker,
+import RnPat (rnPatsAndThen_LocalRightwards, rnBindPat,
+ NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker,
patSigErr)
import RnEnv ( lookupLocatedBndrRn,
-> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName)
rnTopBindsLHS fix_env binds =
- (uncurry $ rnValBindsLHSFromDoc True) (bindersAndDoc binds) fix_env binds
+ (uncurry $ rnValBindsLHSFromDoc (topRecNameMaker fix_env)) (bindersAndDoc binds) binds
rnTopBindsRHS :: [Name] -- the names bound by these binds
-> HsValBindsLR Name RdrName
-- Do error checking: we need to check for dups here because we
-- don't don't bind all of the variables from the ValBinds at once
-- with bindLocatedLocals any more.
- --
- checkDupNames doc boundNames
- -- Warn about shadowing, but only in source modules
- ifOptM Opt_WarnNameShadowing (checkShadowing doc boundNames)
+ checkDupNames doc boundNames
+ checkShadowing doc boundNames
-- (Note that we don't want to do this at the top level, since
-- sorting out duplicates and shadowing there happens elsewhere.
-- import A(f)
-- g = let f = ... in f
-- should.
- rnValBindsLHSFromDoc False boundNames doc fix_env binds
+ rnValBindsLHSFromDoc (localRecNameMaker fix_env) boundNames doc binds
bindersAndDoc :: HsValBinds RdrName -> ([Located RdrName], SDoc)
bindersAndDoc binds =
-- renames the left-hand sides
-- generic version used both at the top level and for local binds
-- does some error checking, but not what gets done elsewhere at the top level
-rnValBindsLHSFromDoc :: Bool -- top or not
+rnValBindsLHSFromDoc :: NameMaker
-> [Located RdrName] -- RdrNames of the LHS (so we don't have to gather them twice)
-> SDoc -- doc string for dup names and shadowing
- -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
- -- these fixities need to be brought into scope with the names
-> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName)
-rnValBindsLHSFromDoc topP original_bndrs doc fix_env binds@(ValBindsIn mbinds sigs)
+rnValBindsLHSFromDoc topP original_bndrs doc binds@(ValBindsIn mbinds sigs)
= do
-- rename the LHSes
- mbinds' <- mapBagM (rnBindLHS topP doc fix_env) mbinds
+ mbinds' <- mapBagM (rnBindLHS topP doc) mbinds
return $ ValBindsIn mbinds' sigs
-- assumes the LHS vars are in scope
let bound_names = map unLoc $ collectHsValBinders new_lhs
-- and bring them (and their fixities) into scope
- bindLocalNamesFV_WithFixities bound_names new_fixities $ do
+ bindLocalNamesFV_WithFixities bound_names new_fixities $
+ warnUnusedLocalBinds bound_names $ do
-- (C) do the RHS and thing inside
(binds', dus) <- rnValBindsRHS bound_names new_lhs
-- bindings in the wrong order, and the type checker will complain
-- that x isn't in scope
- -- check for unused binders. note that we only want to do
- -- this for local ValBinds; it gets done elsewhere for
- -- top-level binds (where the scoping is different)
- unused_bndrs = [ b | b <- bound_names, not (b `elemNameSet` all_uses)]
-
- warnUnusedLocalBinds unused_bndrs
-
return (result,
-- the bound names are pruned out of all_uses
-- by the bindLocalNamesFV call above
-- renaming a single bind
-rnBindLHS :: Bool -- top if true; local if false
+rnBindLHS :: NameMaker
-> SDoc
- -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
- -- these fixities need to be brought into scope with the names
-> LHsBind RdrName
-- returns the renamed left-hand side,
-- and the FreeVars *of the LHS*
-- (i.e., any free variables of the pattern)
-> RnM (LHsBindLR Name RdrName)
-rnBindLHS topP doc fix_env (L loc (PatBind { pat_lhs = pat,
+rnBindLHS name_maker doc (L loc (PatBind { pat_lhs = pat,
pat_rhs = grhss,
bind_fvs=bind_fvs,
pat_rhs_ty=pat_rhs_ty
}))
= setSrcSpan loc $ do
-- we don't actually use the FV processing of rnPatsAndThen here
- (pat',pat'_fvs) <- (if topP then rnPat_TopRec else rnPat_LocalRec) fix_env pat
+ (pat',pat'_fvs) <- rnBindPat name_maker pat
return (L loc (PatBind { pat_lhs = pat',
pat_rhs = grhss,
-- we temporarily store the pat's FVs here;
-- when we rename the RHS
pat_rhs_ty = pat_rhs_ty }))
-rnBindLHS topP doc fix_env (L loc (FunBind { fun_id = name@(L nameLoc _),
+rnBindLHS name_maker doc (L loc (FunBind { fun_id = name@(L nameLoc _),
fun_infix = inf,
fun_matches = matches,
fun_co_fn = fun_co_fn,
bind_fvs = bind_fvs,
fun_tick = fun_tick
}))
- = setSrcSpan loc $ do
- newname <- applyNameMaker (if topP then topNameMaker else localNameMaker) name
- return (L loc (FunBind { fun_id = L nameLoc newname,
- fun_infix = inf,
- fun_matches = matches,
- -- we temporatily store the LHS's FVs (empty in this case) here
- -- gets updated when doing the RHS below
- bind_fvs = emptyFVs,
- -- everything else will get ignored in the next pass
- fun_co_fn = fun_co_fn,
- fun_tick = fun_tick
- }))
+ = setSrcSpan loc $
+ do { (newname, _fvs) <- applyNameMaker name_maker name $ \ newname ->
+ return (newname, emptyFVs)
+ ; return (L loc (FunBind { fun_id = L nameLoc newname,
+ fun_infix = inf,
+ fun_matches = matches,
+ -- we temporatily store the LHS's FVs (empty in this case) here
+ -- gets updated when doing the RHS below
+ bind_fvs = emptyFVs,
+ -- everything else will get ignored in the next pass
+ fun_co_fn = fun_co_fn,
+ fun_tick = fun_tick
+ })) }
-- assumes the left-hands-side vars are in scope
rnBind :: (Name -> [Name]) -- Signature tyvar function
-- Now the main event
-- note that there are no local ficity decls for matches
- rnPatsAndThen_LocalRightwards ctxt pats $ \ (pats',_) ->
+ rnPatsAndThen_LocalRightwards ctxt pats $ \ pats' ->
rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) ->
returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc,
srcLocSpan, getLoc, combineSrcSpans, isOneLineSpan )
import Outputable
-import Util ( sortLe )
+import Util
import Maybes
import ListSetOps ( removeDups )
import List ( nubBy )
-- Used for nested fixity decls to bind names along with their fixities.
-- the fixities are given as a UFM from an OccName's FastString to a fixity decl
-bindLocalNamesFV_WithFixities :: [Name] -> UniqFM (Located Fixity) -> RnM (a, FreeVars) -> RnM (a, FreeVars)
-bindLocalNamesFV_WithFixities names fixities cont =
+-- Also check for unused binders
+bindLocalNamesFV_WithFixities :: [Name]
+ -> UniqFM (Located Fixity)
+ -> RnM (a, FreeVars) -> RnM (a, FreeVars)
+bindLocalNamesFV_WithFixities names fixities thing_inside
+ = bindLocalNamesFV names $
+ extendFixityEnv boundFixities $
+ thing_inside
+ where
-- find the names that have fixity decls
- let boundFixities = foldr
+ boundFixities = foldr
(\ name -> \ acc ->
-- check whether this name has a fixity decl
case lookupUFM fixities (occNameFS (nameOccName name)) of
Just (L _ fix) -> (name, FixItem (nameOccName name) fix) : acc
- Nothing -> acc) [] names in
+ Nothing -> acc) [] names
-- bind the names; extend the fixity env; do the thing inside
- bindLocalNamesFV names (extendFixityEnv boundFixities cont)
\end{code}
--------------------------------
= -- Check for duplicate names
checkDupNames doc_str rdr_names_w_loc `thenM_`
- -- Warn about shadowing, but only in source modules
- ifOptM Opt_WarnNameShadowing
- (checkShadowing doc_str rdr_names_w_loc) `thenM_`
+ -- Warn about shadowing
+ checkShadowing doc_str rdr_names_w_loc `thenM_`
-- Make fresh Names and extend the environment
newLocalsRn rdr_names_w_loc `thenM` \ names ->
-------------------------------------
checkShadowing doc_str loc_rdr_names
- = getLocalRdrEnv `thenM` \ local_env ->
+ = traceRn (text "shadow" <+> ppr loc_rdr_names) `thenM_`
+ getLocalRdrEnv `thenM` \ local_env ->
getGlobalRdrEnv `thenM` \ global_env ->
let
check_shadow (L loc rdr_name)
- | rdr_name `elemLocalRdrEnv` local_env
- || not (null (lookupGRE_RdrName rdr_name global_env ))
- = addWarnAt loc (shadowedNameWarn doc_str rdr_name)
- | otherwise = returnM ()
+ | Just n <- mb_local = complain [ptext SLIT("bound at") <+> ppr (nameSrcLoc n)]
+ | not (null gres) = complain (map pprNameProvenance gres)
+ | otherwise = return ()
+ where
+ complain pp_locs = addWarnAt loc (shadowedNameWarn doc_str rdr_name pp_locs)
+ mb_local = lookupLocalRdrEnv local_env rdr_name
+ gres = lookupGRE_RdrName rdr_name global_env
in
- mappM_ check_shadow loc_rdr_names
+ ifOptM Opt_WarnNameShadowing (mappM_ check_shadow loc_rdr_names)
\end{code}
-- because some of the rename functions are CPSed:
-- maps the function across the list from left to right;
-- collects all the free vars into one set
-mapFvRnCPS :: (a -> ((b,FreeVars) -> RnM (c, FreeVars)) -> RnM(c, FreeVars))
- -> [a]
- -> (([b],FreeVars) -> RnM (c, FreeVars))
- -> RnM (c, FreeVars)
-
-mapFvRnCPS _ [] cont = cont ([], emptyFVs)
+mapFvRnCPS :: (a -> (b -> RnM c) -> RnM c)
+ -> [a] -> ([b] -> RnM c) -> RnM c
-mapFvRnCPS f (h:t) cont = f h $ \ (h',hfv) ->
- mapFvRnCPS f t $ \ (t',tfv) ->
- cont (h':t', hfv `plusFV` tfv)
+mapFvRnCPS _ [] cont = cont []
+mapFvRnCPS f (x:xs) cont = f x $ \ x' ->
+ mapFvRnCPS f xs $ \ xs' ->
+ cont (x':xs')
\end{code}
warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres)
warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds (warnUnusedGREs gres)
-warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM ()
-warnUnusedLocalBinds names = ifOptM Opt_WarnUnusedBinds (warnUnusedLocals names)
-warnUnusedMatches names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals names)
+warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
+warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds
+warnUnusedMatches = check_unused Opt_WarnUnusedMatches
+
+check_unused :: DynFlag -> [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
+check_unused flag names thing_inside
+ = do { (res, res_fvs) <- thing_inside
+
+ -- Warn about unused names
+ ; ifOptM flag (warnUnusedLocals (filterOut (`elemNameSet` res_fvs) names))
+
+ -- And return
+ ; return (res, res_fvs) }
-------------------------
-- Helpers
msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps]
mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre
-shadowedNameWarn doc shadow
- = hsep [ptext SLIT("This binding for"),
- quotes (ppr shadow),
- ptext SLIT("shadows an existing binding")]
+shadowedNameWarn doc rdr_name shadowed_locs
+ = sep [ptext SLIT("This binding for") <+> quotes (ppr rdr_name)
+ <+> ptext SLIT("shadows the existing binding") <> plural shadowed_locs,
+ nest 2 (vcat shadowed_locs)]
$$ doc
unknownNameErr rdr_name
-- for details\r
\r
module RnPat (-- main entry points\r
- rnPatsAndThen_LocalRightwards, rnPat_LocalRec, rnPat_TopRec,\r
+ rnPatsAndThen_LocalRightwards, rnBindPat,\r
\r
NameMaker, applyNameMaker, -- a utility for making names:\r
- localNameMaker, topNameMaker, -- sometimes we want to make local names,\r
+ localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names,\r
-- sometimes we want to make top (qualified) names.\r
\r
rnHsRecFields_Con, rnHsRecFields_Update, --rename record fields in a constructor\r
\begin{code}\r
-- externally abstract type of name makers,\r
-- which is how you go from a RdrName to a Name\r
-data NameMaker = NM (Located RdrName -> RnM Name)\r
-localNameMaker = NM (\name -> do [newname] <- newLocalsRn [name]\r
- return newname)\r
-\r
-topNameMaker = NM (\name -> do mod <- getModule\r
- newTopSrcBinder mod name)\r
-\r
-applyNameMaker :: NameMaker -> Located RdrName -> RnM Name\r
-applyNameMaker (NM f) x = f x\r
+data NameMaker = NM (forall a. Located RdrName -> (Name -> RnM (a, FreeVars))\r
+ -> RnM (a, FreeVars))\r
+\r
+matchNameMaker :: NameMaker\r
+matchNameMaker\r
+ = NM (\ rdr_name thing_inside -> \r
+ do { names@[name] <- newLocalsRn [rdr_name]\r
+ ; bindLocalNamesFV names $\r
+ warnUnusedMatches names $\r
+ thing_inside name })\r
+ \r
+topRecNameMaker, localRecNameMaker\r
+ :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
+ -- these fixities need to be brought into scope with the names\r
+ -> NameMaker\r
+\r
+-- topNameMaker and localBindMaker do not check for unused binding\r
+localRecNameMaker fix_env\r
+ = NM (\ rdr_name thing_inside -> \r
+ do { [name] <- newLocalsRn [rdr_name]\r
+ ; bindLocalNamesFV_WithFixities [name] fix_env $\r
+ thing_inside name })\r
+ \r
+topRecNameMaker fix_env\r
+ = NM (\rdr_name thing_inside -> \r
+ do { mod <- getModule\r
+ ; name <- newTopSrcBinder mod rdr_name\r
+ ; bindLocalNamesFV_WithFixities [name] fix_env $\r
+ thing_inside name })\r
+ -- Note: the bindLocalNamesFV_WithFixities is somewhat suspicious \r
+ -- because it binds a top-level name as a local name.\r
+ -- however, this binding seems to work, and it only exists for\r
+ -- the duration of the patterns and the continuation;\r
+ -- then the top-level name is added to the global env\r
+ -- before going on to the RHSes (see RnSource.lhs).\r
+\r
+applyNameMaker :: NameMaker -> Located RdrName\r
+ -> (Name -> RnM (a,FreeVars)) -> RnM (a, FreeVars)\r
+applyNameMaker (NM f) = f\r
\r
\r
-- There are various entry points to renaming patterns, depending on\r
-- the continuation gets:\r
-- the list of renamed patterns\r
-- the (overall) free vars of all of them\r
- -> (([LPat Name], FreeVars) -> RnM (a, FreeVars))\r
+ -> ([LPat Name] -> RnM (a, FreeVars))\r
-> RnM (a, FreeVars)\r
\r
-rnPatsAndThen_LocalRightwards ctxt pats thing_inside = \r
- -- (0) bring into scope all of the type variables bound by the patterns\r
- bindPatSigTyVarsFV (collectSigTysFromPats pats) $ \r
- -- (1) rename the patterns, bringing into scope all of the term variables\r
- rnLPatsAndThen localNameMaker emptyUFM pats $ \ (pats', pat_fvs) ->\r
- -- (2) then do the thing inside.\r
- thing_inside (pats', pat_fvs) `thenM` \ (res, res_fvs) ->\r
- let\r
- -- walk again to collect the names bound by the pattern\r
- new_bndrs = collectPatsBinders pats'\r
-\r
- -- uses now include both pattern uses and thing_inside uses\r
- used = res_fvs `plusFV` pat_fvs\r
- unused_binders = filter (not . (`elemNameSet` used)) new_bndrs\r
-\r
- -- restore the locations and rdrnames of the new_bndrs\r
- -- lets us use the existing checkDupNames, rather than reimplementing\r
- -- the error reporting for names\r
- new_bndrs_rdr = map (\ n -> (L (nameSrcSpan n) \r
- (mkRdrUnqual (getOccName n)))) new_bndrs\r
- in \r
- -- (3) check for duplicates explicitly\r
- -- (because we don't bind the vars all at once, it doesn't happen\r
- -- for free in the binding)\r
- checkDupNames doc_pat new_bndrs_rdr `thenM_`\r
- -- (4) warn about unused binders\r
- warnUnusedMatches unused_binders `thenM_`\r
- -- (5) return; note that the fvs are pruned by the rnLPatsAndThen\r
- returnM (res, res_fvs `plusFV` pat_fvs)\r
+rnPatsAndThen_LocalRightwards ctxt pats thing_inside\r
+ = do { -- Check for duplicated and shadowed names \r
+ -- Because we don't bind the vars all at once, we can't\r
+ -- check incrementally for duplicates; \r
+ -- Nor can we check incrementally for shadowing, else we'll\r
+ -- complain *twice* about duplicates e.g. f (x,x) = ...\r
+ let rdr_names_w_loc = collectLocatedPatsBinders pats\r
+ ; checkDupNames doc_pat rdr_names_w_loc\r
+ ; checkShadowing doc_pat rdr_names_w_loc\r
+\r
+ -- (0) bring into scope all of the type variables bound by the patterns\r
+ -- (1) rename the patterns, bringing into scope all of the term variables\r
+ -- (2) then do the thing inside.\r
+ ; bindPatSigTyVarsFV (collectSigTysFromPats pats) $ \r
+ rnLPatsAndThen matchNameMaker pats $\r
+ thing_inside }\r
where\r
- doc_pat = ptext SLIT("In") <+> pprMatchContext ctxt\r
+ doc_pat = ptext SLIT("In") <+> pprMatchContext ctxt\r
\r
\r
-- entry point 2:\r
-- local namemaker\r
-- no unused and duplicate checking\r
-- fixities might be coming in\r
-rnPat_LocalRec :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
- -- these fixities need to be brought into scope with the names\r
- -> LPat RdrName\r
- -> RnM (LPat Name, \r
+rnBindPat :: NameMaker\r
+ -> LPat RdrName\r
+ -> RnM (LPat Name, \r
-- free variables of the pattern,\r
-- but not including variables bound by this pattern \r
- FreeVars)\r
+ FreeVars)\r
\r
-rnPat_LocalRec fix_env pat = \r
- rnLPatsAndThen localNameMaker fix_env [pat] $ \ ([pat'], pat_fvs) ->\r
- return (pat', pat_fvs)\r
-\r
-\r
--- entry point 3:\r
--- binds top names; in a recursive scope that involves other bound vars\r
--- does NOT allow type sigs to bind vars\r
--- top namemaker\r
--- no unused and duplicate checking\r
--- fixities might be coming in\r
-rnPat_TopRec :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
- -- these fixities need to be brought into scope with the names\r
- -> LPat RdrName\r
- -> RnM (LPat Name, \r
- -- free variables of the pattern,\r
- -- but not including variables bound by this pattern \r
- FreeVars)\r
-\r
-rnPat_TopRec fix_env pat = \r
- rnLPatsAndThen topNameMaker fix_env [pat] $ \ ([pat'], pat_fvs) ->\r
- return (pat', pat_fvs)\r
+rnBindPat name_maker pat\r
+ = rnLPatsAndThen name_maker [pat] $ \ [pat'] ->\r
+ return (pat', emptyFVs)\r
\r
\r
-- general version: parametrized by how you make new names\r
-- invariant: what-to-do continuation only gets called with a list whose length is the same as\r
-- the part of the pattern we're currently renaming\r
rnLPatsAndThen :: NameMaker -- how to make a new variable\r
- -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
- -- these fixities need to be brought into scope with the names\r
-> [LPat RdrName] -- part of pattern we're currently renaming\r
- -> (([LPat Name],FreeVars) -> RnM (a, FreeVars)) -- what to do afterwards\r
+ -> ([LPat Name] -> RnM (a, FreeVars)) -- what to do afterwards\r
-> RnM (a, FreeVars) -- renaming of the whole thing\r
\r
-rnLPatsAndThen var fix_env = mapFvRnCPS (rnLPatAndThen var fix_env)\r
+rnLPatsAndThen var = mapFvRnCPS (rnLPatAndThen var)\r
\r
\r
-- the workhorse\r
rnLPatAndThen :: NameMaker\r
- -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
- -- these fixities need to be brought into scope with the names\r
-> LPat RdrName -- part of pattern we're currently renaming\r
- -> ((LPat Name, FreeVars) -> RnM (a, FreeVars)) -- what to do afterwards\r
+ -> (LPat Name -> RnM (a, FreeVars)) -- what to do afterwards\r
-> RnM (a, FreeVars) -- renaming of the whole thing\r
-rnLPatAndThen var@(NM varf) fix_env (L loc p) cont = \r
+rnLPatAndThen var@(NM varf) (L loc p) cont = \r
setSrcSpan loc $ \r
let reloc = L loc \r
- lcont = \ (unlocated, fv) -> cont (reloc unlocated, fv)\r
-\r
- -- Note: this is somewhat suspicious because it sometimes\r
- -- binds a top-level name as a local name (when the NameMaker\r
- -- returns a top-level name).\r
- -- however, this binding seems to work, and it only exists for\r
- -- the duration of the patterns and the continuation;\r
- -- then the top-level name is added to the global env\r
- -- before going on to the RHSes (see RnSource.lhs).\r
- --\r
- -- and doing things this way saves us from having to parametrize\r
- -- by the environment extender, repeating the FreeVar handling,\r
- -- etc.\r
- bind n = bindLocalNamesFV_WithFixities [n] fix_env\r
+ lcont = \ unlocated -> cont (reloc unlocated)\r
in\r
case p of\r
- WildPat _ -> lcont (WildPat placeHolderType, emptyFVs)\r
+ WildPat _ -> lcont (WildPat placeHolderType)\r
+\r
+ ParPat pat -> rnLPatAndThen var pat $ \ pat' -> lcont (ParPat pat')\r
+ LazyPat pat -> rnLPatAndThen var pat $ \ pat' -> lcont (LazyPat pat')\r
+ BangPat pat -> rnLPatAndThen var pat $ \ pat' -> lcont (BangPat pat')\r
\r
- VarPat name -> do\r
- newBoundName <- varf (reloc name)\r
+ VarPat name -> \r
+ varf (reloc name) $ \ newBoundName -> \r
+ lcont (VarPat newBoundName)\r
-- we need to bind pattern variables for view pattern expressions\r
-- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)\r
- bind newBoundName $ \r
- (lcont (VarPat newBoundName, emptyFVs))\r
\r
SigPatIn pat ty ->\r
doptM Opt_PatternSignatures `thenM` \ patsigs ->\r
if patsigs\r
- then rnLPatAndThen var fix_env pat\r
- (\ (pat', fvs1) ->\r
- rnHsTypeFVs tvdoc ty `thenM` \ (ty', fvs2) ->\r
- lcont (SigPatIn pat' ty', fvs1 `plusFV` fvs2))\r
+ then rnLPatAndThen var pat\r
+ (\ pat' -> do { (ty', fvs1) <- rnHsTypeFVs tvdoc ty\r
+ ; (res, fvs2) <- lcont (SigPatIn pat' ty')\r
+ ; return (res, fvs1 `plusFV` fvs2) })\r
else addErr (patSigErr ty) `thenM_`\r
- rnLPatAndThen var fix_env pat cont \r
+ rnLPatAndThen var pat cont \r
where\r
tvdoc = text "In a pattern type-signature"\r
\r
LitPat lit@(HsString s) -> \r
do ovlStr <- doptM Opt_OverloadedStrings\r
if ovlStr \r
- then rnLPatAndThen var fix_env (reloc $ mkNPat (mkHsIsString s placeHolderType) Nothing) cont\r
- else do \r
- rnLit lit\r
- lcont (LitPat lit, emptyFVs) -- Same as below\r
+ then rnLPatAndThen var (reloc $ mkNPat (mkHsIsString s placeHolderType) Nothing) cont\r
+ else do { rnLit lit; lcont (LitPat lit) } -- Same as below\r
\r
- LitPat lit -> do \r
- rnLit lit\r
- lcont (LitPat lit, emptyFVs)\r
+ LitPat lit -> do { rnLit lit; lcont (LitPat lit) }\r
\r
NPat lit mb_neg eq ->\r
- rnOverLit lit `thenM` \ (lit', fvs1) ->\r
- (case mb_neg of\r
- Nothing -> returnM (Nothing, emptyFVs)\r
- Just _ -> lookupSyntaxName negateName `thenM` \ (neg, fvs) ->\r
- returnM (Just neg, fvs)\r
- ) `thenM` \ (mb_neg', fvs2) ->\r
- lookupSyntaxName eqName `thenM` \ (eq', fvs3) -> \r
- lcont (NPat lit' mb_neg' eq',\r
- fvs1 `plusFV` fvs2 `plusFV` fvs3) \r
- -- Needed to find equality on pattern\r
-\r
- NPlusKPat name lit _ _ -> do\r
- new_name <- varf name \r
- bind new_name $ \r
- rnOverLit lit `thenM` \ (lit', fvs1) ->\r
- lookupSyntaxName minusName `thenM` \ (minus, fvs2) ->\r
- lookupSyntaxName geName `thenM` \ (ge, fvs3) ->\r
- lcont (NPlusKPat (L (nameSrcSpan new_name) new_name) lit' ge minus,\r
- fvs1 `plusFV` fvs2 `plusFV` fvs3)\r
- -- The Report says that n+k patterns must be in Integral\r
-\r
- LazyPat pat ->\r
- rnLPatAndThen var fix_env pat $ \ (pat', fvs) -> lcont (LazyPat pat', fvs)\r
-\r
- BangPat pat ->\r
- rnLPatAndThen var fix_env pat $ \ (pat', fvs) -> lcont (BangPat pat', fvs)\r
-\r
- AsPat name pat -> do\r
- new_name <- varf name \r
- bind new_name $ \r
- rnLPatAndThen var fix_env pat $ \ (pat', fvs) -> \r
- lcont (AsPat (L (nameSrcSpan new_name) new_name) pat', fvs)\r
+ do { (lit', fvs1) <- rnOverLit lit\r
+ ; (mb_neg', fvs2) <- case mb_neg of\r
+ Nothing -> return (Nothing, emptyFVs)\r
+ Just _ -> do { (neg, fvs) <- lookupSyntaxName negateName\r
+ ; return (Just neg, fvs) }\r
+ ; (eq', fvs3) <- lookupSyntaxName eqName\r
+ ; (res, fvs4) <- lcont (NPat lit' mb_neg' eq')\r
+ ; return (res, fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }\r
+ -- Needed to find equality on pattern\r
+\r
+ NPlusKPat name lit _ _ ->\r
+ varf name $ \ new_name ->\r
+ do { (lit', fvs1) <- rnOverLit lit\r
+ ; (minus, fvs2) <- lookupSyntaxName minusName\r
+ ; (ge, fvs3) <- lookupSyntaxName geName\r
+ ; (res, fvs4) <- lcont (NPlusKPat (L (nameSrcSpan new_name) new_name) lit' ge minus)\r
+ ; return (res, fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }\r
+ -- The Report says that n+k patterns must be in Integral\r
+\r
+ AsPat name pat ->\r
+ varf name $ \ new_name ->\r
+ rnLPatAndThen var pat $ \ pat' -> \r
+ lcont (AsPat (L (nameSrcSpan new_name) new_name) pat')\r
\r
ViewPat expr pat ty -> \r
- do vp_flag <- doptM Opt_ViewPatterns\r
- checkErr vp_flag (badViewPat p)\r
+ do { vp_flag <- doptM Opt_ViewPatterns\r
+ ; checkErr vp_flag (badViewPat p)\r
-- because of the way we're arranging the recursive calls,\r
-- this will be in the right context \r
- (expr', fvExpr) <- rnLExpr expr \r
- rnLPatAndThen var fix_env pat $ \ (pat', fvPat) ->\r
- lcont (ViewPat expr' pat' ty, fvPat `plusFV` fvExpr)\r
+ ; (expr', fv_expr) <- rnLExpr expr \r
+ ; (res, fvs_res) <- rnLPatAndThen var pat $ \ pat' ->\r
+ lcont (ViewPat expr' pat' ty)\r
+ ; return (res, fvs_res `plusFV` fv_expr) }\r
\r
ConPatIn con stuff -> \r
-- rnConPatAndThen takes care of reconstructing the pattern\r
- rnConPatAndThen var fix_env con stuff cont\r
-\r
- ParPat pat -> rnLPatAndThen var fix_env pat $ \r
- \ (pat', fv') -> lcont (ParPat pat', fv')\r
+ rnConPatAndThen var con stuff cont\r
\r
ListPat pats _ -> \r
- rnLPatsAndThen var fix_env pats $ \ (patslist, fvs) ->\r
- lcont (ListPat patslist placeHolderType, fvs)\r
+ rnLPatsAndThen var pats $ \ patslist ->\r
+ lcont (ListPat patslist placeHolderType)\r
\r
PArrPat pats _ -> \r
- rnLPatsAndThen var fix_env pats $ \ (patslist, fvs) ->\r
- lcont (PArrPat patslist placeHolderType, \r
- fvs `plusFV` implicit_fvs)\r
+ do { (res, res_fvs) <- rnLPatsAndThen var pats $ \ patslist ->\r
+ lcont (PArrPat patslist placeHolderType)\r
+ ; return (res, res_fvs `plusFV` implicit_fvs) }\r
where\r
implicit_fvs = mkFVs [lengthPName, indexPName]\r
\r
TuplePat pats boxed _ -> \r
- checkTupSize (length pats) `thenM_`\r
- (rnLPatsAndThen var fix_env pats $ \ (patslist, fvs) ->\r
- lcont (TuplePat patslist boxed placeHolderType, fvs))\r
+ do { checkTupSize (length pats)\r
+ ; rnLPatsAndThen var pats $ \ patslist ->\r
+ lcont (TuplePat patslist boxed placeHolderType) }\r
\r
TypePat name -> \r
- rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) ->\r
- lcont (TypePat name', fvs)\r
+ do { (name', fvs1) <- rnHsTypeFVs (text "In a type pattern") name\r
+ ; (res, fvs2) <- lcont (TypePat name')\r
+ ; return (res, fvs1 `plusFV` fvs2) }\r
\r
\r
-- helper for renaming constructor patterns\r
rnConPatAndThen :: NameMaker\r
- -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
- -- these fixities need to be brought into scope with the names\r
-> Located RdrName -- the constructor\r
-> HsConPatDetails RdrName \r
- -> ((LPat Name, FreeVars) -> RnM (a, FreeVars)) -- what to do afterwards\r
+ -> (LPat Name -> RnM (a, FreeVars)) -- what to do afterwards\r
-> RnM (a, FreeVars)\r
\r
-rnConPatAndThen var fix_env (con@(L loc _)) (PrefixCon pats) cont\r
- = do con' <- lookupLocatedOccRn con\r
- rnLPatsAndThen var fix_env pats $ \r
- \ (pats', fvs) -> \r
- cont (L loc $ ConPatIn con' (PrefixCon pats'),\r
- fvs `addOneFV` unLoc con')\r
-\r
-rnConPatAndThen var fix_env (con@(L loc _)) (InfixCon pat1 pat2) cont\r
- = do con' <- lookupLocatedOccRn con\r
- (rnLPatAndThen var fix_env pat1 $\r
- (\ (pat1', fvs1) -> \r
- rnLPatAndThen var fix_env pat2 $ \r
- (\ (pat2', fvs2) -> do \r
- fixity <- lookupFixityRn (unLoc con')\r
- pat' <- mkConOpPatRn con' fixity pat1' pat2'\r
- cont (L loc pat', fvs1 `plusFV` fvs2 `addOneFV` unLoc con'))))\r
-\r
-rnConPatAndThen var fix_env (con@(L loc _)) (RecCon rpats) cont = do\r
- con' <- lookupLocatedOccRn con\r
- rnHsRecFieldsAndThen_Pattern con' var fix_env rpats $ \ (rpats', fvs) -> \r
- cont (L loc $ ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con')\r
-\r
+rnConPatAndThen var (con@(L loc _)) (PrefixCon pats) cont\r
+ = do { con' <- lookupLocatedOccRn con\r
+ ; (res, res_fvs) <- rnLPatsAndThen var pats $ \ pats' ->\r
+ cont (L loc $ ConPatIn con' (PrefixCon pats'))\r
+ ; return (res, res_fvs `addOneFV` unLoc con') }\r
+\r
+rnConPatAndThen var (con@(L loc _)) (InfixCon pat1 pat2) cont\r
+ = do { con' <- lookupLocatedOccRn con\r
+ ; (res, res_fvs) <- rnLPatAndThen var pat1 $ \ pat1' -> \r
+ rnLPatAndThen var pat2 $ \ pat2' ->\r
+ do { fixity <- lookupFixityRn (unLoc con')\r
+ ; pat' <- mkConOpPatRn con' fixity pat1' pat2'\r
+ ; cont (L loc pat') }\r
+ ; return (res, res_fvs `addOneFV` unLoc con') }\r
+\r
+rnConPatAndThen var (con@(L loc _)) (RecCon rpats) cont\r
+ = do { con' <- lookupLocatedOccRn con\r
+ ; (res, res_fvs) <- rnHsRecFieldsAndThen_Pattern con' var rpats $ \ rpats' -> \r
+ cont (L loc $ ConPatIn con' (RecCon rpats'))\r
+ ; return (res, res_fvs `addOneFV` unLoc con') }\r
\r
-- what kind of record expression we're doing\r
-- the first two tell the name of the datatype constructor in question\r
-- parameterized so that it can also be used for expressions\r
rnHsRecFieldsAndThen :: RnHsRecFieldsChoice field\r
-- how to rename the fields (CPSed)\r
- -> (Located field -> ((Located field', FreeVars) -> RnM (c, FreeVars)) \r
+ -> (Located field -> (Located field' -> RnM (c, FreeVars)) \r
-> RnM (c, FreeVars)) \r
-- the actual fields \r
-> HsRecFields RdrName (Located field) \r
-- what to do in the scope of the field vars\r
- -> ((HsRecFields Name (Located field'), FreeVars) -> RnM (c, FreeVars)) \r
+ -> (HsRecFields Name (Located field') -> RnM (c, FreeVars)) \r
-> RnM (c, FreeVars)\r
-- Haddock comments for record fields are renamed to Nothing here\r
rnHsRecFieldsAndThen choice rn_thing (HsRecFields fields dd) cont = \r
rn_field pun_ok (HsRecField field inside pun) cont = do \r
fieldname <- lookupRecordBndr (getChoiceName choice) field\r
checkErr (not pun || pun_ok) (badPun field)\r
- rn_thing inside $ \ (inside', fvs) -> \r
- cont (HsRecField fieldname inside' pun, \r
- fvs `addOneFV` unLoc fieldname)\r
+ (res, res_fvs) <- rn_thing inside $ \ inside' -> \r
+ cont (HsRecField fieldname inside' pun) \r
+ return (res, res_fvs `addOneFV` unLoc fieldname)\r
\r
-- Compute the extra fields to be filled in by the dot-dot notation\r
dot_dot_fields fs con mk_field cont = do \r
-- because, for patterns, renaming can bind vars in the continuation\r
mapFvRnCPS rn_thing \r
(map (L loc . mk_field . mkRdrUnqual . getOccName) missing_fields) $\r
- \ (rhss, fvs_s) -> \r
+ \ rhss -> \r
let new_fs = [ HsRecField (L loc f) r False\r
| (f, r) <- missing_fields `zip` rhss ]\r
in \r
- cont (new_fs, fvs_s)\r
+ cont new_fs\r
\r
in do\r
-- report duplicate fields\r
-- check whether punning (implicit x=x) is allowed\r
pun_flag <- doptM Opt_RecordPuns\r
-- rename the fields\r
- mapFvRnCPS (rn_field pun_flag) fields $ \ (fields1, fvs1) ->\r
+ mapFvRnCPS (rn_field pun_flag) fields $ \ fields1 ->\r
\r
-- handle ..\r
case dd of\r
- Nothing -> cont (HsRecFields fields1 dd, fvs1)\r
+ Nothing -> cont (HsRecFields fields1 dd)\r
Just n -> ASSERT( n == length fields ) do\r
dd_flag <- doptM Opt_RecordWildCards\r
checkErr dd_flag (needFlagDotDot doingstr)\r
case doDotDot choice of \r
Nothing -> addErr (badDotDot doingstr) `thenM_` \r
-- we return a junk value here so that error reporting goes on\r
- cont (HsRecFields fields1 dd, fvs1)\r
+ cont (HsRecFields fields1 dd)\r
Just (con, mk_field) ->\r
dot_dot_fields fld_names1 con mk_field $\r
- \ (fields2, fvs2) -> \r
- cont (HsRecFields (fields1 ++ fields2) dd, \r
- fvs1 `plusFV` fvs2)\r
+ \ fields2 -> \r
+ cont (HsRecFields (fields1 ++ fields2) dd)\r
\r
needFlagDotDot str = vcat [ptext SLIT("Illegal `..' in record") <+> text str,\r
ptext SLIT("Use -XRecordWildCards to permit this")]\r
-- wrappers\r
rnHsRecFieldsAndThen_Pattern :: Located Name\r
-> NameMaker -- new name maker\r
- -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind\r
- -- these fixities need to be brought into scope with the names\r
-> HsRecFields RdrName (LPat RdrName) \r
- -> ((HsRecFields Name (LPat Name), FreeVars) -> RnM (c, FreeVars)) \r
+ -> (HsRecFields Name (LPat Name) -> RnM (c, FreeVars)) \r
-> RnM (c, FreeVars)\r
-rnHsRecFieldsAndThen_Pattern n var fix_env = rnHsRecFieldsAndThen (Pattern n VarPat) (rnLPatAndThen var fix_env)\r
+rnHsRecFieldsAndThen_Pattern n var\r
+ = rnHsRecFieldsAndThen (Pattern n VarPat) (rnLPatAndThen var)\r
\r
\r
-- wrapper to use rnLExpr in CPS style;\r
-- to be written that way\r
rnLExprAndThen :: (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))\r
-> LHsExpr RdrName \r
- -> ((LHsExpr Name, FreeVars) -> RnM (c, FreeVars)) \r
+ -> (LHsExpr Name -> RnM (c, FreeVars)) \r
-> RnM (c, FreeVars) \r
-rnLExprAndThen f e cont = do {x <- f e; cont x}\r
+rnLExprAndThen f e cont = do { (x, fvs1) <- f e\r
+ ; (res, fvs2) <- cont x\r
+ ; return (res, fvs1 `plusFV` fvs2) }\r
\r
\r
-- non-CPSed because exprs don't leave anything bound\r
-> HsRecFields RdrName (LHsExpr RdrName) \r
-> RnM (HsRecFields Name (LHsExpr Name), FreeVars)\r
rnHsRecFields_Con n rnLExpr fields = rnHsRecFieldsAndThen (Constructor n HsVar) \r
- (rnLExprAndThen rnLExpr) fields return\r
+ (rnLExprAndThen rnLExpr) fields $ \ res ->\r
+ return (res, emptyFVs)\r
\r
rnHsRecFields_Update :: (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))\r
-> HsRecFields RdrName (LHsExpr RdrName) \r
-> RnM (HsRecFields Name (LHsExpr Name), FreeVars)\r
rnHsRecFields_Update rnLExpr fields = rnHsRecFieldsAndThen Update\r
- (rnLExprAndThen rnLExpr) fields return\r
+ (rnLExprAndThen rnLExpr) fields $ \ res -> \r
+ return (res, emptyFVs)\r
\end{code}\r
\r
\r
projects / ghc-hetmet.git / commitdiff