- -> (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 (Constructor _ _) = "construction"
-choiceToMessage (Pattern _ _) = "pattern"
-choiceToMessage Update = "update"
-
-doDotDot (Constructor a b) = Just (a,b)
-doDotDot (Pattern a b) = Just (a,b)
-doDotDot Update = Nothing
-
-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 str = vcat [ptext SLIT("Illegal `..' in record") <+> text str,
- ptext SLIT("Use -XRecordWildCards to permit this")]
-
-badDotDot str = ptext SLIT("You cannot use `..' in record") <+> text str
-
-badPun fld = vcat [ptext SLIT("Illegal use of punning for field") <+> quotes (ppr fld),
- ptext SLIT("Use -XRecordPuns to permit this")]
-
-
--- 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)
+ -> 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))