- -> (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 <- xoptM Opt_RecordPuns
+ ; disambig_ok <- xoptM 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' <- wrapLocM (lookupSubBndr 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 <- xoptM 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 = False }
+ | 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