-- 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
\r
patSigErr ty\r
= (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)\r
- $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))\r
+ $$ nest 4 (ptext SLIT("Use -XPatternSignatures to permit it"))\r
\r
dupFieldErr str dup\r
= hsep [ptext SLIT("duplicate field name"), \r
projects / ghc-hetmet.git / blobdiff