From 2eb04ca0f8d0ec72b417cddc60672c696b4a3daa Mon Sep 17 00:00:00 2001 From: Lemmih Date: Thu, 21 Jun 2007 09:15:52 +0000 Subject: [PATCH] Add several new record features 1. Record disambiguation (-fdisambiguate-record-fields) In record construction and pattern matching (although not in record updates) it is clear which field name is intended even if there are several in scope. This extension uses the constructor to disambiguate. Thus C { x=3 } uses the 'x' field from constructor C (assuming there is one) even if there are many x's in scope. 2. Record punning (-frecord-puns) In a record construction or pattern match or update you can omit the "=" part, thus C { x, y } This is just syntactic sugar for C { x=x, y=y } 3. Dot-dot notation for records (-frecord-dot-dot) In record construction or pattern match (but not update) you can use ".." to mean "all the remaining fields". So C { x=v, .. } means to fill in the remaining fields to give C { x=v, y=y } (assuming C has fields x and y). This might reasonably considered very dodgy stuff. For pattern-matching it brings into scope a bunch of things that are not explictly mentioned; and in record construction it just picks whatver 'y' is in scope for the 'y' field. Still, Lennart Augustsson really wants it, and it's a feature that is extremely easy to explain. Implementation ~~~~~~~~~~~~~~ I thought of using the "parent" field in the GlobalRdrEnv, but that's really used for import/export and just isn't right for this. For example, for import/export a field is a subordinate of the *type constructor* whereas here we need to know what fields belong to a particular *data* constructor. The main thing is that we need to map a data constructor to its fields, and we need to do so in the renamer. For imported modules it's easy: just look in the imported TypeEnv. For the module being compiled, we make a new field tcg_field_env in the TcGblEnv. The important functions are RnEnv.lookupRecordBndr RnEnv.lookupConstructorFields There is still a significant infelicity in the way the renamer works on patterns, which I'll tackle next. I also did quite a bit of refactoring in the representation of record fields (mainly in HsPat).***END OF DESCRIPTION*** Place the long patch description above the ***END OF DESCRIPTION*** marker. The first line of this file will be the patch name. This patch contains the following changes: M ./compiler/deSugar/Check.lhs -3 +5 M ./compiler/deSugar/Coverage.lhs -6 +7 M ./compiler/deSugar/DsExpr.lhs -6 +13 M ./compiler/deSugar/DsMeta.hs -8 +8 M ./compiler/deSugar/DsUtils.lhs -1 +1 M ./compiler/deSugar/MatchCon.lhs -2 +2 M ./compiler/hsSyn/Convert.lhs -3 +3 M ./compiler/hsSyn/HsDecls.lhs -9 +25 M ./compiler/hsSyn/HsExpr.lhs -13 +3 M ./compiler/hsSyn/HsPat.lhs -25 +63 M ./compiler/hsSyn/HsUtils.lhs -3 +3 M ./compiler/main/DynFlags.hs +6 M ./compiler/parser/Parser.y.pp -13 +17 M ./compiler/parser/RdrHsSyn.lhs -16 +18 M ./compiler/rename/RnBinds.lhs -2 +2 M ./compiler/rename/RnEnv.lhs -22 +82 M ./compiler/rename/RnExpr.lhs -34 +12 M ./compiler/rename/RnHsSyn.lhs -3 +2 M ./compiler/rename/RnSource.lhs -50 +78 M ./compiler/rename/RnTypes.lhs -50 +84 M ./compiler/typecheck/TcExpr.lhs -18 +18 M ./compiler/typecheck/TcHsSyn.lhs -20 +21 M ./compiler/typecheck/TcPat.lhs -8 +6 M ./compiler/typecheck/TcRnMonad.lhs -6 +15 M ./compiler/typecheck/TcRnTypes.lhs -2 +11 M ./compiler/typecheck/TcTyClsDecls.lhs -3 +4 M ./docs/users_guide/flags.xml +7 M ./docs/users_guide/glasgow_exts.xml +42 --- compiler/deSugar/Check.lhs | 8 +- compiler/deSugar/Coverage.lhs | 13 ++-- compiler/deSugar/DsExpr.lhs | 19 +++-- compiler/deSugar/DsMeta.hs | 16 ++-- compiler/deSugar/DsUtils.lhs | 2 +- compiler/deSugar/MatchCon.lhs | 4 +- compiler/hsSyn/Convert.lhs | 6 +- compiler/hsSyn/HsDecls.lhs | 34 ++++++--- compiler/hsSyn/HsExpr.lhs | 16 +--- compiler/hsSyn/HsPat.lhs | 92 ++++++++++++++++------- compiler/hsSyn/HsUtils.lhs | 6 +- compiler/main/DynFlags.hs | 3 + compiler/parser/Parser.y.pp | 30 ++++---- compiler/parser/RdrHsSyn.lhs | 34 +++++---- compiler/rename/RnBinds.lhs | 4 +- compiler/rename/RnEnv.lhs | 104 ++++++++++++++++++++------ compiler/rename/RnExpr.lhs | 46 +++--------- compiler/rename/RnHsSyn.lhs | 5 +- compiler/rename/RnSource.lhs | 130 +++++++++++++++++++------------- compiler/rename/RnTypes.lhs | 140 ++++++++++++++++++++++------------- compiler/typecheck/TcExpr.lhs | 36 ++++----- compiler/typecheck/TcHsSyn.lhs | 41 +++++----- compiler/typecheck/TcPat.lhs | 14 ++-- compiler/typecheck/TcRnMonad.lhs | 21 ++++-- compiler/typecheck/TcRnTypes.lhs | 13 +++- compiler/typecheck/TcTyClsDecls.lhs | 7 +- docs/users_guide/flags.xml | 7 ++ docs/users_guide/glasgow_exts.xml | 42 +++++++++++ 28 files changed, 561 insertions(+), 332 deletions(-) diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index ace132c..32b47b6 100644 --- a/compiler/deSugar/Check.lhs +++ b/compiler/deSugar/Check.lhs @@ -145,7 +145,9 @@ untidy b (L loc p) = L loc (untidy' b p) untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats) untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2) -untidy_con (RecCon bs) = RecCon [ HsRecField f (untidy_pars p) d | HsRecField f p d <- bs ] +untidy_con (RecCon (HsRecFields flds dd)) + = RecCon (HsRecFields [ fld { hsRecFieldArg = untidy_pars (hsRecFieldArg fld) } + | fld <- flds ] dd) pars :: NeedPars -> WarningPat -> Pat Name pars True p = ParPat p @@ -607,7 +609,7 @@ has_nplusk_pat (TuplePat ps _ _) = any has_nplusk_lpat ps has_nplusk_pat (PArrPat ps _) = any has_nplusk_lpat ps has_nplusk_pat (LazyPat p) = False -- Why? has_nplusk_pat (BangPat p) = has_nplusk_lpat p -- I think -has_nplusk_pat (ConPatOut { pat_args = ps }) = any has_nplusk_lpat (hsConArgs ps) +has_nplusk_pat (ConPatOut { pat_args = ps }) = any has_nplusk_lpat (hsConPatArgs ps) has_nplusk_pat p = False -- VarPat, VarPatOut, WildPat, LitPat, NPat, TypePat simplify_lpat :: LPat Id -> LPat Id @@ -666,7 +668,7 @@ simplify_pat (CoPat co pat ty) = simplify_pat pat ----------------- simplify_con con (PrefixCon ps) = PrefixCon (map simplify_lpat ps) simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_lpat p1, simplify_lpat p2] -simplify_con con (RecCon fs) +simplify_con con (RecCon (HsRecFields fs _)) | null fs = PrefixCon [nlWildPat | t <- dataConOrigArgTys con] -- Special case for null patterns; maybe not a record at all | otherwise = PrefixCon (map (simplify_lpat.snd) all_pats) diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 2bbf187..116d3bf 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -495,12 +495,13 @@ addTickDictBinds :: DictBinds Id -> TM (DictBinds Id) addTickDictBinds x = addTickLHsBinds x addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id) -addTickHsRecordBinds (HsRecordBinds pairs) = liftM HsRecordBinds (mapM process pairs) - where - process (ids,expr) = - liftM2 (,) - (return ids) - (addTickLHsExpr expr) +addTickHsRecordBinds (HsRecFields fields dd) + = do { fields' <- mapM process fields + ; return (HsRecFields fields' dd) } + where + process (HsRecField ids expr doc) + = do { expr' <- addTickLHsExpr expr + ; return (HsRecField ids expr' doc) } addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id) addTickArithSeqInfo (From e1) = diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index dd433ec..f9219ba 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -19,6 +19,7 @@ import DsListComp import DsUtils import DsArrows import DsMonad +import Name #ifdef GHCI import PrelNames @@ -407,7 +408,7 @@ We also handle @C{}@ as valid construction syntax for an unlabelled constructor @C@, setting all of @C@'s fields to bottom. \begin{code} -dsExpr (RecordCon (L _ data_con_id) con_expr (HsRecordBinds rbinds)) +dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = dsExpr con_expr `thenDs` \ con_expr' -> let (arg_tys, _) = tcSplitFunTys (exprType con_expr') @@ -415,7 +416,7 @@ dsExpr (RecordCon (L _ data_con_id) con_expr (HsRecordBinds rbinds)) -- hence TcType.tcSplitFunTys mk_arg (arg_ty, lbl) -- Selector id has the field label as its name - = case [rhs | (L _ sel_id, rhs) <- rbinds, lbl == idName sel_id] of + = case findField (rec_flds rbinds) lbl of (rhs:rhss) -> ASSERT( null rhss ) dsLExpr rhs [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl)) @@ -455,10 +456,11 @@ might do some argument-evaluation first; and may have to throw away some dictionaries. \begin{code} -dsExpr (RecordUpd record_expr (HsRecordBinds []) _ _ _) +dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) + cons_to_upd in_inst_tys out_inst_tys) + | null fields = dsLExpr record_expr - -dsExpr expr@(RecordUpd record_expr (HsRecordBinds rbinds) cons_to_upd in_inst_tys out_inst_tys) + | otherwise = -- Record stuff doesn't work for existentials -- The type checker checks for this, but we need -- worry only about the constructors that are to be updated @@ -473,7 +475,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecordBinds rbinds) cons_to_upd in_inst_ty (mkFamilyTyConApp tycon out_inst_tys) mk_val_arg field old_arg_id - = case [rhs | (L _ sel_id, rhs) <- rbinds, field == idName sel_id] of + = case findField fields field of (rhs:rest) -> ASSERT(null rest) rhs [] -> nlHsVar old_arg_id @@ -543,6 +545,11 @@ dsExpr (HsBinTick ixT ixF e) = do dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig" #endif + +findField :: [HsRecField Id arg] -> Name -> [arg] +findField rbinds lbl + = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds + , lbl == idName (unLoc id) ] \end{code} %-------------------------------------------------------------------- diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 11a5323..5b624fb 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -527,11 +527,11 @@ repE e@(ExplicitPArr ty es) = notHandled "Parallel arrays" (ppr e) repE e@(ExplicitTuple es boxed) | isBoxed boxed = do { xs <- repLEs es; repTup xs } | otherwise = notHandled "Unboxed tuples" (ppr e) -repE (RecordCon c _ (HsRecordBinds flds)) +repE (RecordCon c _ flds) = do { x <- lookupLOcc c; fs <- repFields flds; repRecCon x fs } -repE (RecordUpd e (HsRecordBinds flds) _ _ _) +repE (RecordUpd e flds _ _ _) = do { x <- repLE e; fs <- repFields flds; repRecUpd x fs } @@ -613,12 +613,12 @@ repGuards other g <- repPatGE (nonEmptyCoreList ss') rhs' return (gs, g) -repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp]) -repFields flds = do - fnames <- mapM lookupLOcc (map fst flds) - es <- mapM repLE (map snd flds) - fs <- zipWithM repFieldExp fnames es - coreList fieldExpQTyConName fs +repFields :: [HsRecField Name (LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp]) +repFields flds + = do { fnames <- mapM lookupLOcc (map hsRecFieldId flds) + ; es <- mapM repLE (map hsRecFieldArg flds) + ; fs <- zipWithM repFieldExp fnames es + ; coreList fieldExpQTyConName fs } ----------------------------------------------------------------------------- diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 41ef58e..3f34091 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -647,7 +647,7 @@ mkSelectorBinds pat val_expr is_simple_lpat p = is_simple_pat (unLoc p) is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps - is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConArgs ps) + is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConPatArgs ps) is_simple_pat (VarPat _) = True is_simple_pat (ParPat p) = is_simple_lpat p is_simple_pat other = False diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs index 3f25fc7..ed9f2c1 100644 --- a/compiler/deSugar/MatchCon.lhs +++ b/compiler/deSugar/MatchCon.lhs @@ -119,11 +119,11 @@ conArgPats :: DataCon -> [Type] -- Instantiated argument types -- Used only to fill in the types of WildPats, which -- are probably never looked at anyway - -> HsConDetails Id (LPat Id) + -> HsConDetails (LPat Id) (HsRecFields Id (LPat Id)) -> [Pat Id] conArgPats data_con arg_tys (PrefixCon ps) = map unLoc ps conArgPats data_con arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2] -conArgPats data_con arg_tys (RecCon rpats) +conArgPats data_con arg_tys (RecCon (HsRecFields rpats _)) | null rpats = -- Special case for C {}, which can be used for -- a constructor that isn't declared to have diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index db00786..b26787b 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -364,12 +364,12 @@ cvtl e = wrapL (cvt e) ; return $ ExprWithTySig e' t' } cvt (RecConE c flds) = do { c' <- cNameL c ; flds' <- mapM cvtFld flds - ; return $ RecordCon c' noPostTcExpr (HsRecordBinds flds') } + ; return $ RecordCon c' noPostTcExpr flds' } cvt (RecUpdE e flds) = do { e' <- cvtl e ; flds' <- mapM cvtFld flds - ; return $ RecordUpd e' (HsRecordBinds flds') [] [] [] } + ; return $ RecordUpd e' flds' [] [] [] } -cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e; return (v',e') } +cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e; return (mkHsRecField v' e') } cvtDD :: Range -> CvtM (ArithSeqInfo RdrName) cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' } diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 37ab35a..4f0fc03 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -17,7 +17,8 @@ module HsDecls ( DefaultDecl(..), LDefaultDecl, SpliceDecl(..), ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), CImportSpec(..), FoType(..), - ConDecl(..), ResType(..), LConDecl, + ConDecl(..), ResType(..), ConDeclField(..), LConDecl, + HsConDeclDetails, hsConDeclArgTys, DocDecl(..), LDocDecl, docDeclDoc, DeprecDecl(..), LDeprecDecl, HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, @@ -25,7 +26,6 @@ module HsDecls ( isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl, isFamInstDecl, countTyClDecls, - conDetailsTys, instDeclATs, collectRuleBndrSigTys, ) where @@ -650,13 +650,25 @@ data ConDecl name , con_cxt :: LHsContext name -- The context. This *does not* include the -- "stupid theta" which lives only in the TyData decl - , con_details :: HsConDetails name (LBangType name) -- The main payload + , con_details :: HsConDeclDetails name -- The main payload , con_res :: ResType name -- Result type of the constructor , con_doc :: Maybe (LHsDoc name) -- A possible Haddock comment } +type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name] + +hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name] +hsConDeclArgTys (PrefixCon tys) = tys +hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] +hsConDeclArgTys (RecCon flds) = map cd_fld_type flds + +data ConDeclField name -- Record fields have Haddoc docs on them + = ConDeclField { cd_fld_name :: Located name, + cd_fld_type :: LBangType name, + cd_fld_doc :: Maybe (LHsDoc name) } + data ResType name = ResTyH98 -- Constructor was declared using Haskell 98 syntax | ResTyGADT (LHsType name) -- Constructor was declared using GADT-style syntax, @@ -664,7 +676,7 @@ data ResType name \end{code} \begin{code} -conDeclsNames :: Eq name => [ConDecl name] -> [Located name] +conDeclsNames :: forall name. Eq name => [ConDecl name] -> [Located name] -- See tyClDeclNames for what this does -- The function is boringly complicated because of the records -- And since we only have equality, we have to be a little careful @@ -672,14 +684,13 @@ conDeclsNames cons = snd (foldl do_one ([], []) cons) where do_one (flds_seen, acc) (ConDecl { con_name = lname, con_details = RecCon flds }) - = (map unLoc new_flds ++ flds_seen, lname : [f | f <- new_flds] ++ acc) + = (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc) where - new_flds = [ f | (HsRecField f _ _) <- flds, not (unLoc f `elem` flds_seen) ] + new_flds = filterOut (\f -> unLoc f `elem` flds_seen) + (map cd_fld_name flds) do_one (flds_seen, acc) c = (flds_seen, (con_name c):acc) - -conDetailsTys details = map getBangType (hsConArgs details) \end{code} @@ -687,6 +698,7 @@ conDetailsTys details = map getBangType (hsConArgs details) instance (OutputableBndr name) => Outputable (ConDecl name) where ppr = pprConDecl +pprConDecl :: OutputableBndr name => ConDecl name -> SDoc pprConDecl (ConDecl con expl tvs cxt details ResTyH98 doc) = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details] where @@ -703,7 +715,11 @@ pprConDecl (ConDecl con expl tvs cxt (PrefixCon arg_tys) (ResTyGADT res_ty) _) pprConDecl (ConDecl con expl tvs cxt (RecCon fields) (ResTyGADT res_ty) _) = sep [pprHsForAll expl tvs cxt, ppr con <+> ppr_fields fields <+> dcolon <+> ppr res_ty] -ppr_fields fields = braces (sep (punctuate comma (map ppr fields))) +ppr_fields fields = braces (sep (punctuate comma (map ppr_fld fields))) + where + ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty, + cd_fld_doc = doc }) + = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc \end{code} %************************************************************************ diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 44d9b43..9a6a4a8 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -394,10 +394,10 @@ ppr_expr (ExplicitTuple exprs boxity) = tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (RecordCon con_id con_expr rbinds) - = pp_rbinds (ppr con_id) rbinds + = hang (ppr con_id) 2 (ppr rbinds) ppr_expr (RecordUpd aexp rbinds _ _ _) - = pp_rbinds (pprParendExpr aexp) rbinds + = hang (pprParendExpr aexp) 2 (ppr rbinds) ppr_expr (ExprWithTySig expr sig) = hang (nest 2 (ppr_lexpr expr) <+> dcolon) @@ -584,17 +584,7 @@ data HsCmdTop id %************************************************************************ \begin{code} -data HsRecordBinds id = HsRecordBinds [(Located id, LHsExpr id)] - -recBindFields :: HsRecordBinds id -> [id] -recBindFields (HsRecordBinds rbinds) = [unLoc field | (field,_) <- rbinds] - -pp_rbinds :: OutputableBndr id => SDoc -> HsRecordBinds id -> SDoc -pp_rbinds thing (HsRecordBinds rbinds) - = hang thing - 4 (braces (pprDeeperList sep (punctuate comma (map (pp_rbind) rbinds)))) - where - pp_rbind (v, e) = hsep [pprBndr LetBind (unLoc v), char '=', ppr e] +type HsRecordBinds id = HsRecFields id (LHsExpr id) \end{code} diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 42da265..842a4f1 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -8,8 +8,9 @@ module HsPat ( Pat(..), InPat, OutPat, LPat, - HsConDetails(..), hsConArgs, - HsRecField(..), mkRecField, + HsConDetails(..), + HsConPatDetails, hsConPatArgs, + HsRecFields(..), HsRecField(..), hsRecFields, mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat, @@ -85,7 +86,7 @@ data Pat id ------------ Constructor patterns --------------- | ConPatIn (Located id) - (HsConDetails id (LPat id)) + (HsConPatDetails id) | ConPatOut { pat_con :: Located DataCon, @@ -93,7 +94,7 @@ data Pat id -- including any bound coercion variables pat_dicts :: [id], -- Ditto dictionaries pat_binds :: DictBinds id, -- Bindings involving those dictionaries - pat_args :: HsConDetails id (LPat id), + pat_args :: HsConPatDetails id, pat_ty :: Type -- The type of the pattern } @@ -134,26 +135,55 @@ data Pat id -- the scrutinee, followed by a match on 'pat' \end{code} -HsConDetails is use both for patterns and for data type declarations +HsConDetails is use for patterns/expressions *and* for data type declarations \begin{code} -data HsConDetails id arg - = PrefixCon [arg] -- C p1 p2 p3 - | RecCon [HsRecField id arg] -- C { x = p1, y = p2 } - | InfixCon arg arg -- p1 `C` p2 +data HsConDetails arg rec + = PrefixCon [arg] -- C p1 p2 p3 + | RecCon rec -- C { x = p1, y = p2 } + | InfixCon arg arg -- p1 `C` p2 + +type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id)) + +hsConPatArgs :: HsConPatDetails id -> [LPat id] +hsConPatArgs (PrefixCon ps) = ps +hsConPatArgs (RecCon fs) = map hsRecFieldArg (rec_flds fs) +hsConPatArgs (InfixCon p1 p2) = [p1,p2] +\end{code} + +However HsRecFields is used only for patterns and expressions +(not data type declarations) + +\begin{code} +data HsRecFields id arg -- A bunch of record fields + -- { x = 3, y = True } + -- Used for both expressiona and patterns + = HsRecFields { rec_flds :: [HsRecField id arg], + rec_dotdot :: Maybe Int } + -- Nothing => the normal case + -- Just n => the group uses ".." notation, + -- and the first n elts of rec_flds + -- were the user-written ones + -- (In the latter case, the remaining elts of + -- rec_flds are the non-user-written ones) data HsRecField id arg = HsRecField { hsRecFieldId :: Located id, hsRecFieldArg :: arg, - hsRecFieldDoc :: Maybe (LHsDoc id) -} - -mkRecField id arg = HsRecField id arg Nothing - -hsConArgs :: HsConDetails id arg -> [arg] -hsConArgs (PrefixCon ps) = ps -hsConArgs (RecCon fs) = map hsRecFieldArg fs -hsConArgs (InfixCon p1 p2) = [p1,p2] + hsRecPun :: Bool -- Note [Punning] + } + +-- Note [Punning] +-- ~~~~~~~~~~~~~~ +-- If you write T { x, y = v+1 }, the HsRecFields will be +-- HsRecField x x True ... +-- HsRecField y (v+1) False ... +-- That is, for "punned" field x is immediately expanded to x=x +-- but with a punning flag so we can detect it later +-- (e.g. when pretty printing) + +hsRecFields :: HsRecFields id arg -> [id] +hsRecFields rbinds = map (unLoc . hsRecFieldId) (rec_flds rbinds) \end{code} @@ -212,19 +242,27 @@ pprUserCon c details = ppr c <+> pprConArgs details pprConArgs (PrefixCon pats) = interppSP pats pprConArgs (InfixCon p1 p2) = interppSP [p1,p2] -pprConArgs (RecCon rpats) = braces (hsep (punctuate comma (map (pp_rpat) rpats))) - where - pp_rpat (HsRecField v p _d) = - hsep [ppr v, char '=', ppr p] +pprConArgs (RecCon rpats) = ppr rpats + +instance (OutputableBndr id, Outputable arg) + => Outputable (HsRecFields id arg) where + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) + = braces (fsep (punctuate comma (map ppr flds))) + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n }) + = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) + where + dotdot = ptext SLIT("..") <+> ifPprDebug (ppr (drop n flds)) + +instance (OutputableBndr id, Outputable arg) + => Outputable (HsRecField id arg) where + ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg, + hsRecPun = pun }) + = ppr f <+> (if pun then empty else equals <+> ppr arg) -- add parallel array brackets around a document -- pabrackets :: SDoc -> SDoc pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") - -instance (OutputableBndr id, Outputable arg) => - Outputable (HsRecField id arg) where - ppr (HsRecField n ty doc) = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc \end{code} @@ -343,7 +381,7 @@ isIrrefutableHsPat pat go1 (ConPatIn _ _) = False -- Conservative go1 (ConPatOut{ pat_con = L _ con, pat_args = details }) = isProductTyCon (dataConTyCon con) - && all go (hsConArgs details) + && all go (hsConPatArgs details) go1 (LitPat _) = False go1 (NPat _ _ _ _) = False diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index c1d1a10..e16a0bd 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -383,8 +383,8 @@ collectl (L l pat) bndrs go (PArrPat pats _) = foldr collectl bndrs pats go (TuplePat pats _ _) = foldr collectl bndrs pats - go (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps) - go (ConPatOut {pat_args=ps}) = foldr collectl bndrs (hsConArgs ps) + go (ConPatIn c ps) = foldr collectl bndrs (hsConPatArgs ps) + go (ConPatOut {pat_args=ps}) = foldr collectl bndrs (hsConPatArgs ps) -- See Note [Dictionary binders in ConPatOut] go (LitPat _) = bndrs go (NPat _ _ _ _) = bndrs @@ -425,6 +425,6 @@ collect_pat (ParPat pat) acc = collect_lpat pat acc collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats -collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps) +collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConPatArgs ps) collect_pat other acc = acc -- Literals, vars, wildcard \end{code} diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index a0882f2..0a18964 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -177,6 +177,9 @@ data DynFlag | Opt_BangPatterns | Opt_TypeFamilies | Opt_OverloadedStrings + | Opt_DisambiguateRecordFields + | Opt_RecordDotDot + | Opt_RecordPuns | Opt_GADTs | Opt_RelaxedPolyRec -- -X=RelaxedPolyRec diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 277ddb0..82f6474 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1136,7 +1136,7 @@ forall :: { Located [LHsTyVarBndr RdrName] } : 'forall' tv_bndrs '.' { LL $2 } | {- empty -} { noLoc [] } -constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) } +constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) } -- We parse the constructor declaration -- C t1 t2 -- as a btype (treating C as a type constructor) and then convert C to be @@ -1149,7 +1149,7 @@ constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrN | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.LL } | btype conop btype { LL ($2, InfixCon $1 $3) } -constr_stuff_record :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) } +constr_stuff_record :: { Located (Located RdrName, HsConDeclDetails RdrName) } : oqtycon '{' '}' {% mkRecCon $1 [] >>= return.sL (comb2 $1 $>) } | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.sL (comb2 $1 $>) } @@ -1321,9 +1321,8 @@ aexp :: { LHsExpr RdrName } | aexp1 { $1 } aexp1 :: { LHsExpr RdrName } - : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) - $3; - return (LL r) }} + : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) $3 + ; return (LL r) }} | aexp2 { $1 } -- Here was the syntax for type applications that I was planning @@ -1548,16 +1547,21 @@ qual :: { LStmt RdrName } ----------------------------------------------------------------------------- -- Record Field Update/Construction -fbinds :: { HsRecordBinds RdrName } - : fbinds1 { HsRecordBinds (reverse $1) } - | {- empty -} { HsRecordBinds [] } +fbinds :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) } + : fbinds1 { $1 } + | {- empty -} { ([], False) } -fbinds1 :: { [(Located id, LHsExpr id)] } - : fbinds1 ',' fbind { $3 : $1 } - | fbind { [$1] } +fbinds1 :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) } + : fbind ',' fbinds1 { case $3 of (flds, dd) -> ($1 : flds, dd) } + | fbind { ([$1], False) } + | '..' { ([], True) } -fbind :: { (Located RdrName, LHsExpr RdrName) } - : qvar '=' exp { ($1,$3) } +fbind :: { HsRecField RdrName (LHsExpr RdrName) } + : qvar '=' exp { HsRecField $1 $3 False } + | qvar { HsRecField $1 (L (getLoc $1) (HsVar (unLoc $1))) True } + -- Here's where we say that plain 'x' + -- means exactly 'x = x'. The pun-flag boolean is + -- there so we can still print it right ----------------------------------------------------------------------------- -- Implicit Parameter Bindings diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 9cc6c65..c4526f8 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -348,7 +348,7 @@ add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) -- arguments, and converts the type constructor back into a data constructor. mkPrefixCon :: LHsType RdrName -> [LBangType RdrName] - -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName)) + -> P (Located RdrName, HsConDeclDetails RdrName) mkPrefixCon ty tys = split ty tys where @@ -359,10 +359,10 @@ mkPrefixCon ty tys mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] -> - P (Located RdrName, HsConDetails RdrName (LBangType RdrName)) + P (Located RdrName, HsConDeclDetails RdrName) mkRecCon (L loc con) fields = do data_con <- tyConToDataCon loc con - return (data_con, RecCon [ (HsRecField l t d) | (ls, t, d) <- fields, l <- ls ]) + return (data_con, RecCon [ ConDeclField l t d | (ls, t, d) <- fields, l <- ls ]) tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName) tyConToDataCon loc tc @@ -689,8 +689,9 @@ checkAPat loc e = case e of ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps -> return (TuplePat ps b placeHolderType) - RecordCon c _ (HsRecordBinds fs) -> mapM checkPatField fs >>= \fs -> - return (ConPatIn c (RecCon (map (uncurry mkRecField) fs))) + RecordCon c _ (HsRecFields fs dd) + -> mapM checkPatField fs >>= \fs -> + return (ConPatIn c (RecCon (HsRecFields fs dd))) -- Generics HsType ty -> return (TypePat ty) _ -> patFail loc @@ -699,10 +700,9 @@ plus_RDR, bang_RDR :: RdrName plus_RDR = mkUnqual varName FSLIT("+") -- Hack bang_RDR = mkUnqual varName FSLIT("!") -- Hack -checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName) -checkPatField (n,e) = do - p <- checkLPat e - return (n,p) +checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName)) +checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld) + ; return (fld { hsRecFieldArg = p }) } patFail loc = parseError loc "Parse error in pattern" @@ -852,15 +852,17 @@ checkPrecP (L l i) mkRecConstrOrUpdate :: LHsExpr RdrName -> SrcSpan - -> HsRecordBinds RdrName + -> ([HsRecField RdrName (LHsExpr RdrName)], Bool) -> P (HsExpr RdrName) -mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c - = return (RecordCon (L l c) noPostTcExpr fs) -mkRecConstrOrUpdate exp loc fs@(HsRecordBinds (_:_)) - = return (RecordUpd exp fs [] [] []) -mkRecConstrOrUpdate _ loc (HsRecordBinds []) - = parseError loc "Empty record update" +mkRecConstrOrUpdate (L l (HsVar c)) loc (fs,dd) | isRdrDataCon c + = return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd)) +mkRecConstrOrUpdate exp loc (fs,dd) + | null fs = parseError loc "Empty record update" + | otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] []) + +mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } +mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) } mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec -- The Maybe is becuase the user can omit the activation spec (and usually does) diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 1c7bebb..029f51c 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -27,7 +27,7 @@ import TcRnMonad import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs, rnLPat, rnPatsAndThen, patSigErr, checkPrecMatch ) import RnEnv ( bindLocatedLocalsRn, lookupLocatedBndrRn, - lookupLocatedInstDeclBndr, newIPNameRn, + lookupInstDeclBndr, newIPNameRn, lookupLocatedSigOccRn, bindPatSigTyVarsFV, bindLocalFixities, bindSigTyVarsFV, warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, @@ -422,7 +422,7 @@ rnMethodBinds cls sig_fn gen_tyvars binds rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = inf, fun_matches = MatchGroup matches _ })) = setSrcSpan loc $ - lookupLocatedInstDeclBndr cls name `thenM` \ sel_name -> + lookupInstDeclBndr cls name `thenM` \ sel_name -> let plain_name = unLoc sel_name in -- We use the selector name as the binder diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 6f347da..51b30c3 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -12,7 +12,7 @@ module RnEnv ( lookupLocatedGlobalOccRn, lookupGlobalOccRn, lookupLocalDataTcNames, lookupSrcOcc_maybe, lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, - lookupLocatedInstDeclBndr, + lookupInstDeclBndr, lookupRecordBndr, lookupConstructorFields, lookupSyntaxName, lookupSyntaxTable, lookupImportedName, lookupGreRn, lookupGreRn_maybe, getLookupOccRn, @@ -50,10 +50,13 @@ import RdrName ( RdrName, isQual, isUnqual, isOrig_maybe, importSpecLoc, importSpecModule ) import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) +import TcEnv ( tcLookupDataCon ) import TcRnMonad import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, nameSrcLoc, nameOccName, nameModule, isExternalName ) import NameSet +import NameEnv +import DataCon ( dataConFieldLabels ) import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, reportIfUnused ) import Module ( Module, ModuleName ) @@ -64,6 +67,7 @@ import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc, srcLocSpan, getLoc, combineSrcSpans, isOneLineSpan ) import Outputable import Util ( sortLe ) +import Maybes import ListSetOps ( removeDups ) import List ( nubBy ) import Monad ( when ) @@ -215,33 +219,88 @@ lookupLocatedSigOccRn = wrapLocM $ \ rdr_name -> do Nothing -> lookupGlobalOccRn rdr_name }}} --- lookupInstDeclBndr is used for the binders in an --- instance declaration. Here we use the class name to --- disambiguate. - -lookupLocatedInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name) -lookupLocatedInstDeclBndr cls rdr = wrapLocM (lookupInstDeclBndr cls) rdr - -lookupInstDeclBndr :: Name -> RdrName -> RnM Name +----------------------------------------------- +lookupInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name) -- This is called on the method name on the left-hand side of an -- instance declaration binding. eg. instance Functor T where -- fmap = ... -- ^^^^ called on this -- Regardless of how many unqualified fmaps are in scope, we want -- the one that comes from the Functor class. -lookupInstDeclBndr cls_name rdr_name +-- +-- Furthermore, note that we take no account of whether the +-- 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 + (ptext SLIT("method of class")) rdr + where + doc = ptext SLIT("method of class") <+> quotes (ppr cls) + is_op gre@(GRE {gre_par = ParentIs n}) = n == cls + is_op other = False + +----------------------------------------------- +lookupRecordBndr :: Maybe (Located Name) -> Located RdrName -> RnM (Located Name) +-- Used for record construction and pattern matching +-- When the -fdisambiguate-record-fields flag is on, take account of the +-- constructor name to disambiguate which field to use; it's just the +-- same as for instance decls +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, +-- which is itself gathered from the (as yet un-typechecked) +-- data type decls +-- +-- * For constructors from imported modules, use the *type* environment +-- since imported modles are already compiled, the info is conveniently +-- right there + +lookupConstructorFields con_name + = do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod con_name then + do { field_env <- getRecFieldEnv + ; return (lookupNameEnv field_env con_name `orElse` []) } + else + do { con <- tcLookupDataCon con_name + ; return (dataConFieldLabels con) } } + +----------------------------------------------- +lookup_located_sub_bndr :: (GlobalRdrElt -> Bool) + -> 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 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 - let { is_op gre@(GRE {gre_par = ParentIs n}) = cls_name == n - ; is_op other = False - ; occ = rdrNameOcc rdr_name - ; lookup_fn env = filter is_op (lookupGlobalRdrEnv env occ) } - ; mb_gre <- lookupGreRn_help rdr_name lookup_fn - ; case mb_gre of - Just gre -> return (gre_name gre) - Nothing -> do { addErr (unknownInstBndrErr cls_name rdr_name) - ; traceRn (text "lookupInstDeclBndr" <+> ppr rdr_name) - ; return (mkUnboundName rdr_name) } } + ; env <- getGlobalRdrEnv + ; case filter is_good (lookupGlobalRdrEnv env (rdrNameOcc rdr_name)) 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) + [] -> do { addErr (unknownSubordinateErr doc rdr_name) + ; traceRn (text "RnEnv.lookup_sub_bndr" <+> ppr rdr_name) + ; return (mkUnboundName rdr_name) } + gres -> do { addNameClashErrRn rdr_name gres + ; return (gre_name (head gres)) } + } | otherwise -- Occurs in derived instances, where we just -- refer directly to the right method @@ -855,8 +914,9 @@ unknownNameErr rdr_name nest 2 $ pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) <+> quotes (ppr rdr_name)] -unknownInstBndrErr cls op - = quotes (ppr op) <+> ptext SLIT("is not a (visible) method of class") <+> quotes (ppr cls) +unknownSubordinateErr doc op -- Doc is "method of class" or + -- "field of constructor" + = quotes (ppr op) <+> ptext SLIT("is not a (visible)") <+> doc badOrigBinding name = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 8cc8c89..ff6e412 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -26,7 +26,7 @@ import HscTypes ( availNames ) import RnNames ( getLocalDeclBinders, extendRdrEnvRn ) import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit, mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec, - dupFieldErr, checkTupSize ) + rnHsRecFields, checkTupSize ) import DynFlags ( DynFlag(..) ) import BasicTypes ( FixityDirection(..) ) import SrcLoc ( SrcSpan ) @@ -219,17 +219,18 @@ rnExpr e@(ExplicitTuple exps boxity) rnExprs exps `thenM` \ (exps', fvs) -> returnM (ExplicitTuple exps' boxity, fvs) -rnExpr (RecordCon con_id _ (HsRecordBinds rbinds)) - = lookupLocatedOccRn con_id `thenM` \ conname -> - rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) -> - returnM (RecordCon conname noPostTcExpr (HsRecordBinds rbinds'), - fvRbinds `addOneFV` unLoc conname) +rnExpr (RecordCon con_id _ rbinds) + = do { conname <- lookupLocatedOccRn con_id + ; (rbinds', fvRbinds) <- rnHsRecFields "construction" (Just conname) + rnLExpr HsVar rbinds + ; return (RecordCon conname noPostTcExpr rbinds', + fvRbinds `addOneFV` unLoc conname) } -rnExpr (RecordUpd expr (HsRecordBinds rbinds) _ _ _) - = rnLExpr expr `thenM` \ (expr', fvExpr) -> - rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) -> - returnM (RecordUpd expr' (HsRecordBinds rbinds') [] [] [], - fvExpr `plusFV` fvRbinds) +rnExpr (RecordUpd expr rbinds _ _ _) + = do { (expr', fvExpr) <- rnLExpr expr + ; (rbinds', fvRbinds) <- rnHsRecFields "update" Nothing rnLExpr HsVar rbinds + ; return (RecordUpd expr' rbinds' [] [] [], + fvExpr `plusFV` fvRbinds) } rnExpr (ExprWithTySig expr pty) = do { (pty', fvTy) <- rnHsTypeFVs doc pty @@ -501,29 +502,6 @@ rnArithSeq (FromThenTo expr1 expr2 expr3) plusFVs [fvExpr1, fvExpr2, fvExpr3]) \end{code} - -%************************************************************************ -%* * -\subsubsection{@Rbinds@s and @Rpats@s: in record expressions} -%* * -%************************************************************************ - -\begin{code} -rnRbinds str rbinds - = mappM_ field_dup_err dup_fields `thenM_` - mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) -> - returnM (rbinds', fvRbind) - where - (_, dup_fields) = removeDups cmpLocated [ f | (f,_) <- rbinds ] - - field_dup_err dups = mappM_ (\f -> addLocErr f (dupFieldErr str)) dups - - rn_rbind (field, expr) - = lookupLocatedGlobalOccRn field `thenM` \ fieldname -> - rnLExpr expr `thenM` \ (expr', fvExpr) -> - returnM ((fieldname, expr'), fvExpr `addOneFV` unLoc fieldname) -\end{code} - %************************************************************************ %* * Template Haskell brackets diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs index 8774b40..4f40a8d 100644 --- a/compiler/rename/RnHsSyn.lhs +++ b/compiler/rename/RnHsSyn.lhs @@ -130,9 +130,8 @@ conDeclFVs (L _ (ConDecl { con_qvars = tyvars, con_cxt = context, conResTyFVs ResTyH98 = emptyFVs conResTyFVs (ResTyGADT ty) = extractHsTyNames ty -conDetailsFVs (PrefixCon btys) = plusFVs (map bangTyFVs btys) -conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2 -conDetailsFVs (RecCon flds) = plusFVs [bangTyFVs bty | (HsRecField _ bty _) <- flds] +conDetailsFVs :: HsConDeclDetails Name -> FreeVars +conDetailsFVs details = plusFVs (map bangTyFVs (hsConDeclArgTys details)) bangTyFVs bty = extractHsTyNames (getBangType bty) \end{code} diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 041a34c..71415fa 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -84,15 +84,10 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, -- Deal with top-level fixity decls -- (returns the total new fixity env) rn_fix_decls <- rnSrcFixityDecls fix_decls ; - fix_env <- rnSrcFixityDeclsEnv rn_fix_decls ; - updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env }) - $ do { - - -- Rename other declarations - traceRn (text "Start rnmono") ; - (rn_val_decls, bind_dus) <- rnTopBinds val_decls ; - traceRn (text "finish rnmono" <+> ppr rn_val_decls) ; + tcg_env <- extendGblFixityEnv rn_fix_decls ; + setGblEnv tcg_env $ do { + -- Rename type and class decls -- You might think that we could build proper def/use information -- for type and class declarations, but they can be involved -- in mutual recursion across modules, and we only do the SCC @@ -101,7 +96,18 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, -- means we'll only report a declaration as unused if it isn't -- mentioned at all. Ah well. traceRn (text "Start rnTyClDecls") ; - (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ; + (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ; + + -- Extract the mapping from data constructors to field names + tcg_env <- extendRecordFieldEnv rn_tycl_decls ; + setGblEnv tcg_env $ do { + + -- Value declarations + traceRn (text "Start rnmono") ; + (rn_val_decls, bind_dus) <- rnTopBinds val_decls ; + traceRn (text "finish rnmono" <+> ppr rn_val_decls) ; + + -- Other decls (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ; (rn_rule_decls, src_fvs3) <- rnList rnHsRuleDecl rule_decls ; (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ; @@ -134,9 +140,8 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, traceRn (text "finish rnSrc" <+> ppr rn_group) ; traceRn (text "finish Dus" <+> ppr src_dus ) ; - tcg_env <- getGblEnv ; return (tcg_env `addTcgDUs` src_dus, rn_group) - }}} + }}}} rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name] -- Used for external core @@ -182,38 +187,39 @@ rnDocDecl (DocGroup lev doc) = do \begin{code} rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name] +-- First rename the fixity decls, so we can put +-- the renamed decls in the renamed syntax tre rnSrcFixityDecls fix_decls - = do fix_decls <- mapM rnFixityDecl fix_decls - return (concat fix_decls) - -rnFixityDecl :: LFixitySig RdrName -> RnM [LFixitySig Name] -rnFixityDecl (L loc (FixitySig (L nameLoc rdr_name) fixity)) - = setSrcSpan nameLoc $ + = do fix_decls <- mapM rn_decl fix_decls + return (concat fix_decls) + where + rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name] -- GHC extension: look up both the tycon and data con - -- for con-like things + -- for con-like things; hence returning a list -- If neither are in scope, report an error; otherwise -- add both to the fixity env - do names <- lookupLocalDataTcNames rdr_name - return [ L loc (FixitySig (L nameLoc name) fixity) - | name <- names ] - -rnSrcFixityDeclsEnv :: [LFixitySig Name] -> RnM FixityEnv -rnSrcFixityDeclsEnv fix_decls - = getGblEnv `thenM` \ gbl_env -> - foldlM rnFixityDeclEnv (tcg_fix_env gbl_env) - fix_decls `thenM` \ fix_env -> - traceRn (text "fixity env" <+> pprFixEnv fix_env) `thenM_` - returnM fix_env - -rnFixityDeclEnv :: FixityEnv -> LFixitySig Name -> RnM FixityEnv -rnFixityDeclEnv fix_env (L loc (FixitySig (L nameLoc name) fixity)) - = case lookupNameEnv fix_env name of - Just (FixItem _ _ loc') - -> do addLocErr (L nameLoc name) (dupFixityDecl loc') - return fix_env - Nothing - -> return (extendNameEnv fix_env name fix_item) - where fix_item = FixItem (nameOccName name) fixity nameLoc + rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity)) + = setSrcSpan name_loc $ + do names <- lookupLocalDataTcNames rdr_name + return [ L loc (FixitySig (L name_loc name) fixity) + | name <- names ] + +extendGblFixityEnv :: [LFixitySig Name] -> RnM TcGblEnv +-- Extend the global envt with fixity decls, checking for duplicate decls +extendGblFixityEnv decls + = do { env <- getGblEnv + ; fix_env' <- foldlM add_one (tcg_fix_env env) decls + ; return (env { tcg_fix_env = fix_env' }) } + where + add_one fix_env (L loc (FixitySig (L name_loc name) fixity)) + | Just (FixItem _ _ loc') <- lookupNameEnv fix_env name + = do { setSrcSpan loc $ + addLocErr (L name_loc name) (dupFixityDecl loc') + ; return fix_env } + | otherwise + = return (extendNameEnv fix_env name fix_item) + where + fix_item = FixItem (nameOccName name) fixity loc pprFixEnv :: FixityEnv -> SDoc pprFixEnv env @@ -719,7 +725,7 @@ rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc) -- For GADT syntax, the tvs are all the quantified tyvars -- Hence the 'filter' in the ResTyH98 case only ; let not_in_scope = not . (`elemLocalRdrEnv` name_env) . unLoc - arg_tys = hsConArgs details + arg_tys = hsConDeclArgTys details implicit_tvs = case res_ty of ResTyH98 -> filter not_in_scope $ get_rdr_tvs arg_tys @@ -732,7 +738,7 @@ rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc) ; bindTyVarsRn doc tvs' $ \new_tyvars -> do { new_context <- rnContext doc cxt - ; new_details <- rnConDetails doc details + ; new_details <- rnConDeclDetails doc details ; (new_details', new_res_ty) <- rnConResult doc new_details res_ty ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty mb_doc') }} where @@ -750,28 +756,26 @@ rnConResult doc details (ResTyGADT ty) = do RecCon fields -> return (details, ResTyGADT ty') InfixCon {} -> panic "rnConResult" -rnConDetails doc (PrefixCon tys) +rnConDeclDetails doc (PrefixCon tys) = mappM (rnLHsType doc) tys `thenM` \ new_tys -> returnM (PrefixCon new_tys) -rnConDetails doc (InfixCon ty1 ty2) +rnConDeclDetails doc (InfixCon ty1 ty2) = rnLHsType doc ty1 `thenM` \ new_ty1 -> rnLHsType doc ty2 `thenM` \ new_ty2 -> returnM (InfixCon new_ty1 new_ty2) -rnConDetails doc (RecCon fields) - = checkDupNames doc field_names `thenM_` - mappM (rnField doc) fields `thenM` \ new_fields -> - returnM (RecCon new_fields) - where - field_names = [ name | HsRecField name _ _ <- fields ] +rnConDeclDetails doc (RecCon fields) + = do { checkDupNames doc (map cd_fld_name fields) + ; new_fields <- mappM (rnField doc) fields + ; return (RecCon new_fields) } -- Document comments are renamed to Nothing here -rnField doc (HsRecField name ty haddock_doc) +rnField doc (ConDeclField name ty haddock_doc) = lookupLocatedTopBndrRn name `thenM` \ new_name -> rnLHsType doc ty `thenM` \ new_ty -> rnMbLHsDoc haddock_doc `thenM` \ new_haddock_doc -> - returnM (HsRecField new_name new_ty new_haddock_doc) + returnM (ConDeclField new_name new_ty new_haddock_doc) -- Rename family declarations -- @@ -869,6 +873,30 @@ badDataCon name %********************************************************* %* * +\subsection{Support code for type/data declarations} +%* * +%********************************************************* + +Get the mapping from constructors to fields for this module. +It's convenient to do this after the data type decls have been renamed +\begin{code} +extendRecordFieldEnv :: [LTyClDecl Name] -> TcM TcGblEnv +extendRecordFieldEnv decls + = do { tcg_env <- getGblEnv + ; let field_env' = foldr get (tcg_field_env tcg_env) decls + ; return (tcg_env { tcg_field_env = field_env' }) } + where + get (L _ (TyData { tcdCons = cons })) env = foldr get_con env cons + get other env = env + + get_con (L _ (ConDecl { con_name = con, con_details = RecCon flds })) env + = extendNameEnv env (unLoc con) (map (unLoc . cd_fld_name) flds) + get_con other env + = env +\end{code} + +%********************************************************* +%* * \subsection{Support code to rename types} %* * %********************************************************* diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 82bf50a..b061834 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -10,19 +10,19 @@ module RnTypes ( rnHsSigType, rnHsTypeFVs, -- Patterns and literals - rnLPat, rnPat, rnPatsAndThen, -- Here because it's not part + rnLPat, rnPatsAndThen, -- Here because it's not part rnLit, rnOverLit, -- of any mutual recursion + rnHsRecFields, -- Precence related stuff mkOpAppRn, mkNegAppRn, mkOpFormRn, checkPrecMatch, checkSectionPrec, -- Error messages - dupFieldErr, patSigErr, checkTupSize + patSigErr, checkTupSize ) where -import DynFlags ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts, Opt_ScopedTypeVariables, Opt_OverloadedStrings ) ) - +import DynFlags import HsSyn import RdrHsSyn ( extractHsRhoRdrTyVars ) import RnHsSyn ( extractHsTyNames, parrTyCon_name, tupleTyCon_name, @@ -32,25 +32,25 @@ import RnHsDoc ( rnLHsDoc ) import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, lookupLocatedOccRn, lookupLocatedBndrRn, lookupLocatedGlobalOccRn, bindTyVarsRn, - lookupFixityRn, lookupTyFixityRn, - mapFvRn, warnUnusedMatches, + lookupFixityRn, lookupTyFixityRn, lookupConstructorFields, + lookupRecordBndr, mapFvRn, warnUnusedMatches, newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV ) import TcRnMonad -import RdrName ( RdrName, elemLocalRdrEnv ) +import RdrName import PrelNames ( eqClassName, integralClassName, geName, eqName, negateName, minusName, lengthPName, indexPName, plusIntegerName, fromIntegerName, timesIntegerName, ratioDataConName, fromRationalName, fromStringName ) import TypeRep ( funTyCon ) import Constants ( mAX_TUPLE_SIZE ) -import Name ( Name ) -import SrcLoc ( SrcSpan, Located(..), unLoc, noLoc, combineLocs ) +import Name +import SrcLoc import NameSet import Literal ( inIntRange, inCharRange ) import BasicTypes ( compareFixity, funTyFixity, negateFixity, Fixity(..), FixityDirection(..) ) -import ListSetOps ( removeDups ) +import ListSetOps ( removeDups, minusList ) import Outputable #include "HsVersions.h" @@ -386,19 +386,17 @@ mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name -> RnM (Pat Name) mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 - = lookupFixityRn (unLoc op1) `thenM` \ fix1 -> - let - (nofix_error, associate_right) = compareFixity fix1 fix2 - in - if nofix_error then - addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` - returnM (ConPatIn op2 (InfixCon p1 p2)) - else - if associate_right then - mkConOpPatRn op2 fix2 p12 p2 `thenM` \ new_p -> - returnM (ConPatIn op1 (InfixCon p11 (L loc new_p))) -- XXX loc right? - else - returnM (ConPatIn op2 (InfixCon p1 p2)) + = do { fix1 <- lookupFixityRn (unLoc op1) + ; let (nofix_error, associate_right) = compareFixity fix1 fix2 + + ; if nofix_error then do + { addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) + ; return (ConPatIn op2 (InfixCon p1 p2)) } + + else if associate_right then do + { new_p <- mkConOpPatRn op2 fix2 p12 p2 + ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right? + else return (ConPatIn op2 (InfixCon p1 p2)) } mkConOpPatRn op fix p1 p2 -- Default case, no rearrangment = ASSERT( not_op_pat (unLoc p2) ) @@ -630,7 +628,6 @@ rnPat (AsPat name pat) rnPat (ConPatIn con stuff) = rnConPat con stuff - rnPat (ParPat pat) = rnLPat pat `thenM` \ (pat', fvs) -> returnM (ParPat pat', fvs) @@ -658,44 +655,81 @@ rnPat (TypePat name) = -- ----------------------------------------------------------------------------- -- rnConPat +rnConPat :: Located RdrName -> HsConPatDetails RdrName -> RnM (Pat Name, FreeVars) rnConPat con (PrefixCon pats) - = lookupLocatedOccRn con `thenM` \ con' -> - rnLPats pats `thenM` \ (pats', fvs) -> - returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` unLoc con') + = do { con' <- lookupLocatedOccRn con + ; (pats', fvs) <- rnLPats pats + ; return (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` unLoc con') } rnConPat con (RecCon rpats) - = lookupLocatedOccRn con `thenM` \ con' -> - rnRpats rpats `thenM` \ (rpats', fvs) -> - returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con') + = do { con' <- lookupLocatedOccRn con + ; (rpats', fvs) <- rnHsRecFields "pattern" (Just con') rnLPat VarPat rpats + ; return (ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con') } rnConPat con (InfixCon pat1 pat2) - = lookupLocatedOccRn con `thenM` \ con' -> - rnLPat pat1 `thenM` \ (pat1', fvs1) -> - rnLPat pat2 `thenM` \ (pat2', fvs2) -> - lookupFixityRn (unLoc con') `thenM` \ fixity -> - mkConOpPatRn con' fixity pat1' pat2' `thenM` \ pat' -> - returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` unLoc con') + = do { con' <- lookupLocatedOccRn con + ; (pat1', fvs1) <- rnLPat pat1 + ; (pat2', fvs2) <- rnLPat pat2 + ; fixity <- lookupFixityRn (unLoc con') + ; pat' <- mkConOpPatRn con' fixity pat1' pat2' + ; return (pat', fvs1 `plusFV` fvs2 `addOneFV` unLoc con') } -- ----------------------------------------------------------------------------- --- rnRpats - +rnHsRecFields :: String -- "pattern" or "construction" or "update" + -> Maybe (Located Name) + -> (Located a -> RnM (Located b, FreeVars)) + -> (RdrName -> a) -- How to fill in ".." + -> HsRecFields RdrName (Located a) + -> RnM (HsRecFields Name (Located b), FreeVars) -- Haddock comments for record fields are renamed to Nothing here -rnRpats :: [HsRecField RdrName (LPat RdrName)] - -> RnM ([HsRecField Name (LPat Name)], FreeVars) -rnRpats rpats - = mappM_ field_dup_err dup_fields `thenM_` - mapFvRn rn_rpat rpats `thenM` \ (rpats', fvs) -> - returnM (rpats', fvs) +rnHsRecFields str mb_con rn_thing mk_rhs (HsRecFields fields dd) + = do { mappM_ field_dup_err dup_fields + ; pun_flag <- doptM Opt_RecordPuns + ; (fields1, fvs1) <- mapFvRn (rn_rpat pun_flag) fields + ; case dd of + Nothing -> return (HsRecFields fields1 dd, fvs1) + Just n -> ASSERT( n == length fields ) do + { dd_flag <- doptM Opt_RecordDotDot + ; checkErr dd_flag (needFlagDotDot str) + + ; let fld_names1 = map (unLoc . hsRecFieldId) fields1 + ; (fields2, fvs2) <- dot_dot_fields fld_names1 mb_con + + ; return (HsRecFields (fields1 ++ fields2) dd, fvs1 `plusFV` fvs2) } } where - (_, dup_fields) = removeDups compare [ unLoc f | HsRecField f _ _ <- rpats ] - - field_dup_err dups = addErr (dupFieldErr "pattern" dups) - - rn_rpat (HsRecField field pat _) - = lookupLocatedGlobalOccRn field `thenM` \ fieldname -> - rnLPat pat `thenM` \ (pat', fvs) -> - returnM ((mkRecField fieldname pat'), fvs `addOneFV` unLoc fieldname) - + (_, dup_fields) = removeDups compare (map (unLoc . hsRecFieldId) fields) + + field_dup_err dups = addErr (dupFieldErr str (head dups)) + + rn_rpat pun_ok (HsRecField field pat pun) + = do { fieldname <- lookupRecordBndr mb_con field + ; checkErr (not pun || pun_ok) (badPun field) + ; (pat', fvs) <- rn_thing pat + ; return (HsRecField fieldname pat' pun, + fvs `addOneFV` unLoc fieldname) } + + dot_dot_fields fs Nothing = do { addErr (badDotDot str) + ; return ([], emptyFVs) } + + -- Compute the extra fields to be filled in by the dot-dot notation + dot_dot_fields fs (Just con) + = do { con_fields <- lookupConstructorFields (unLoc con) + ; let missing_fields = con_fields `minusList` fs + ; loc <- getSrcSpanM -- Rather approximate + ; (rhss, fvs_s) <- mapAndUnzipM rn_thing + [ L loc (mk_rhs (mkRdrUnqual (getOccName f))) + | f <- missing_fields ] + ; let new_fs = [ HsRecField (L loc f) r False + | (f, r) <- missing_fields `zip` rhss ] + ; return (new_fs, plusFVs fvs_s) } + +needFlagDotDot str = vcat [ptext SLIT("Illegal `..' in record") <+> text str, + ptext SLIT("Use -frecord-dot-dot 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 -frecord-puns to permit this")] \end{code} diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 39e8a5c..a3ed96c 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -384,20 +384,21 @@ tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty -- don't know how to do the update otherwise. -tcExpr expr@(RecordUpd record_expr hrbinds@(HsRecordBinds rbinds) _ _ _) res_ty +tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty = -- STEP 0 -- Check that the field names are really field names - ASSERT( notNull rbinds ) let - field_names = map fst rbinds + field_names = hsRecFields rbinds in - mappM (tcLookupField . unLoc) field_names `thenM` \ sel_ids -> + ASSERT( notNull field_names ) + mappM tcLookupField field_names `thenM` \ sel_ids -> -- The renamer has already checked that they -- are all in scope let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name) - | (L loc field_name, sel_id) <- field_names `zip` sel_ids, - not (isRecordSelector sel_id) -- Excludes class ops + | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids, + not (isRecordSelector sel_id), -- Excludes class ops + let L loc field_name = hsRecFieldId fld ] in checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM) `thenM_` @@ -406,21 +407,20 @@ tcExpr expr@(RecordUpd record_expr hrbinds@(HsRecordBinds rbinds) _ _ _) res_ty -- Figure out the tycon and data cons from the first field name let -- It's OK to use the non-tc splitters here (for a selector) - upd_field_lbls = recBindFields hrbinds sel_id : _ = sel_ids (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if data_cons = tyConDataCons tycon -- it's not a field label -- NB: for a data type family, the tycon is the instance tycon relevant_cons = filter is_relevant data_cons - is_relevant con = all (`elem` dataConFieldLabels con) upd_field_lbls + is_relevant con = all (`elem` dataConFieldLabels con) field_names in -- STEP 2 -- Check that at least one constructor has all the named fields -- i.e. has an empty set of bad fields returned by badFields checkTc (not (null relevant_cons)) - (badFieldsUpd hrbinds) `thenM_` + (badFieldsUpd rbinds) `thenM_` -- Check that all relevant data cons are vanilla. Doing record updates on -- GADTs and/or existentials is more than my tiny brain can cope with today @@ -440,7 +440,7 @@ tcExpr expr@(RecordUpd record_expr hrbinds@(HsRecordBinds rbinds) _ _ _) res_ty (con1_tyvars, theta, con1_arg_tys, con1_res_ty) = dataConSig con1 con1_flds = dataConFieldLabels con1 common_tyvars = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys - , not (fld `elem` upd_field_lbls) ] + , not (fld `elem` field_names) ] is_common_tv tv = tv `elemVarSet` common_tyvars @@ -460,7 +460,7 @@ tcExpr expr@(RecordUpd record_expr hrbinds@(HsRecordBinds rbinds) _ _ _) res_ty con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys in tcSubExp result_ty res_ty `thenM` \ co_fn -> - tcRecordBinds con1 con1_arg_tys' hrbinds `thenM` \ rbinds' -> + tcRecordBinds con1 con1_arg_tys' rbinds `thenM` \ rbinds' -> -- STEP 5: Typecheck the expression to be updated let @@ -488,7 +488,7 @@ tcExpr expr@(RecordUpd record_expr hrbinds@(HsRecordBinds rbinds) _ _ _) res_ty = idHsWrapper in -- Phew! - returnM (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds' + returnM (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds' relevant_cons scrut_inst_tys result_inst_tys)) \end{code} @@ -1058,18 +1058,18 @@ tcRecordBinds -> HsRecordBinds Name -> TcM (HsRecordBinds TcId) -tcRecordBinds data_con arg_tys (HsRecordBinds rbinds) +tcRecordBinds data_con arg_tys (HsRecFields rbinds dd) = do { mb_binds <- mappM do_bind rbinds - ; return (HsRecordBinds (catMaybes mb_binds)) } + ; return (HsRecFields (catMaybes mb_binds) dd) } where flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys - do_bind (L loc field_lbl, rhs) + do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs }) | Just field_ty <- assocMaybe flds_w_tys field_lbl = addErrCtxt (fieldCtxt field_lbl) $ do { rhs' <- tcPolyExprNC rhs field_ty ; sel_id <- tcLookupField field_lbl ; ASSERT( isRecordSelector sel_id ) - return (Just (L loc sel_id, rhs')) } + return (Just (fld { hsRecFieldId = L loc sel_id, hsRecFieldArg = rhs' })) } | otherwise = do { addErrTc (badFieldCon data_con field_lbl) ; return Nothing } @@ -1104,7 +1104,7 @@ checkMissingFields data_con rbinds not (fl `elem` field_names_used) ] - field_names_used = recBindFields rbinds + field_names_used = hsRecFields rbinds field_labels = dataConFieldLabels data_con field_info = zipEqual "missingFields" @@ -1146,7 +1146,7 @@ nonVanillaUpd tycon ptext SLIT("Use pattern-matching instead")] badFieldsUpd rbinds = hang (ptext SLIT("No constructor has all these fields:")) - 4 (pprQuotedList (recBindFields rbinds)) + 4 (pprQuotedList (hsRecFields rbinds)) naughtyRecordSel sel_id = ptext SLIT("Cannot use record selector") <+> quotes (ppr sel_id) <+> diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index eaa7b23..acb3d2b 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -452,16 +452,16 @@ zonkExpr env (ExplicitTuple exprs boxed) returnM (ExplicitTuple new_exprs boxed) zonkExpr env (RecordCon data_con con_expr rbinds) - = zonkExpr env con_expr `thenM` \ new_con_expr -> - zonkRbinds env rbinds `thenM` \ new_rbinds -> - returnM (RecordCon data_con new_con_expr new_rbinds) + = do { new_con_expr <- zonkExpr env con_expr + ; new_rbinds <- zonkRecFields env rbinds + ; return (RecordCon data_con new_con_expr new_rbinds) } zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys) - = zonkLExpr env expr `thenM` \ new_expr -> - mapM (zonkTcTypeToType env) in_tys `thenM` \ new_in_tys -> - mapM (zonkTcTypeToType env) out_tys `thenM` \ new_out_tys -> - zonkRbinds env rbinds `thenM` \ new_rbinds -> - returnM (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) + = do { new_expr <- zonkLExpr env expr + ; new_in_tys <- mapM (zonkTcTypeToType env) in_tys + ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys + ; new_rbinds <- zonkRecFields env rbinds + ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) } zonkExpr env (ExprWithTySigOut e ty) = do { e' <- zonkLExpr env e @@ -639,14 +639,15 @@ zonkStmt env (BindStmt pat expr bind_op fail_op) ------------------------------------------------------------------------- -zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id) - -zonkRbinds env (HsRecordBinds rbinds) - = mappM zonk_rbind rbinds >>= return . HsRecordBinds +zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId) +zonkRecFields env (HsRecFields flds dd) + = do { flds' <- mappM zonk_rbind flds + ; return (HsRecFields flds dd) } where - zonk_rbind (field, expr) - = zonkLExpr env expr `thenM` \ new_expr -> - returnM (fmap (zonkIdOcc env) field, new_expr) + zonk_rbind fld + = do { new_expr <- zonkLExpr env (hsRecFieldArg fld) + ; return (fld { hsRecFieldArg = new_expr }) } + -- Field selectors have declared types; hence no zonking ------------------------------------------------------------------------- mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b) @@ -764,11 +765,11 @@ zonkConStuff env (InfixCon p1 p2) ; (env', p2') <- zonkPat env1 p2 ; return (env', InfixCon p1' p2') } -zonkConStuff env (RecCon rpats) - = do { let (fields, pats) = unzip [ (f, p) | HsRecField f p _ <- rpats ] - ; (env', pats') <- zonkPats env pats - ; let recCon = RecCon [ mkRecField f p | (f, p) <- zip fields pats' ] - ; returnM (env', recCon) } +zonkConStuff env (RecCon (HsRecFields rpats dd)) + = do { (env', pats') <- zonkPats env (map hsRecFieldArg rpats) + ; let rpats' = zipWith (\rp p' -> rp { hsRecFieldArg = p' }) rpats pats' + ; returnM (env', RecCon (HsRecFields rpats' dd)) } + -- Field selectors have declared types; hence no zonking --------------------------- zonkPats env [] = return (env, []) diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index 097402f..4d5aaf6 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -544,7 +544,7 @@ further type refinement is local to the alternative. tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon -> BoxySigmaType -- Type of the pattern - -> HsConDetails Name (LPat Name) -> (PatState -> TcM a) + -> HsConPatDetails Name -> (PatState -> TcM a) -> TcM (Pat TcId, [TcTyVar], a) tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside = do { let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con @@ -622,8 +622,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside tcConArgs :: DataCon -> [TcSigmaType] - -> Checker (HsConDetails Name (LPat Name)) - (HsConDetails Id (LPat Id)) + -> Checker (HsConPatDetails Name) (HsConPatDetails Id) tcConArgs data_con arg_tys (PrefixCon arg_pats) pstate thing_inside = do { checkTc (con_arity == no_of_args) -- Check correct arity @@ -648,16 +647,15 @@ tcConArgs data_con [arg_ty1,arg_ty2] (InfixCon p1 p2) pstate thing_inside tcConArgs data_con other_args (InfixCon p1 p2) pstate thing_inside = pprPanic "tcConArgs" (ppr data_con) -- InfixCon always has two arguments -tcConArgs data_con arg_tys (RecCon rpats) pstate thing_inside +tcConArgs data_con arg_tys (RecCon (HsRecFields rpats dd)) pstate thing_inside = do { (rpats', tvs, res) <- tcMultiple tc_field rpats pstate thing_inside - ; return (RecCon rpats', tvs, res) } + ; return (RecCon (HsRecFields rpats' dd), tvs, res) } where - -- doc comments are typechecked to Nothing here tc_field :: Checker (HsRecField FieldLabel (LPat Name)) (HsRecField TcId (LPat TcId)) - tc_field (HsRecField field_lbl pat _) pstate thing_inside + tc_field (HsRecField field_lbl pat pun) pstate thing_inside = do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl ; (pat', tvs, res) <- tcConArg (pat, pat_ty) pstate thing_inside - ; return (mkRecField sel_id pat', tvs, res) } + ; return (HsRecField sel_id pat' pun, tvs, res) } find_field_ty :: FieldLabel -> TcM (Id, TcType) find_field_ty field_lbl diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 64b40f6..84b5aee 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -84,12 +84,13 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this | otherwise = Nothing ; gbl_env = TcGblEnv { - tcg_mod = mod, - tcg_src = hsc_src, - tcg_rdr_env = hsc_global_rdr_env hsc_env, - tcg_fix_env = emptyNameEnv, - tcg_default = Nothing, - tcg_type_env = hsc_global_type_env hsc_env, + tcg_mod = mod, + tcg_src = hsc_src, + tcg_rdr_env = hsc_global_rdr_env hsc_env, + tcg_fix_env = emptyNameEnv, + tcg_field_env = emptyNameEnv, + tcg_default = Nothing, + tcg_type_env = hsc_global_type_env hsc_env, tcg_type_env_var = type_env_var, tcg_inst_env = emptyInstEnv, tcg_fam_inst_env = emptyFamInstEnv, @@ -403,6 +404,14 @@ extendFixityEnv new_bit = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) +getRecFieldEnv :: TcRn RecFieldEnv +getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) } + +extendRecFieldEnv :: RecFieldEnv -> RnM a -> RnM a +extendRecFieldEnv new_bit + = updGblEnv (\env@(TcGblEnv { tcg_field_env = old_env }) -> + env {tcg_field_env = old_env `plusNameEnv` new_bit}) + getDeclaredDefaultTys :: TcRn (Maybe [Type]) getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } \end{code} diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 3c23921..be37c16 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -13,7 +13,7 @@ module TcRnTypes( IfGblEnv(..), IfLclEnv(..), -- Ranamer types - ErrCtxt, + ErrCtxt, RecFieldEnv, ImportAvails(..), emptyImportAvails, plusImportAvails, WhereFrom(..), mkModDeps, @@ -133,7 +133,8 @@ data TcGblEnv tcg_default :: Maybe [Type], -- Types used for defaulting -- Nothing => no 'default' decl - tcg_fix_env :: FixityEnv, -- Just for things in this module + tcg_fix_env :: FixityEnv, -- Just for things in this module + tcg_field_env :: RecFieldEnv, -- Just for things in this module tcg_type_env :: TypeEnv, -- Global type env for the module we are compiling now -- All TyCons and Classes (for this module) end up in here right away, @@ -227,6 +228,14 @@ data TcGblEnv tcg_doc :: Maybe (HsDoc Name), -- Maybe Haddock documentation tcg_hmi :: HaddockModInfo Name -- Haddock module information } + +type RecFieldEnv = NameEnv [Name] -- Maps a constructor name *in this module* + -- to the fields for that constructor + -- This is used when dealing with ".." notation in record + -- construction and pattern matching. + -- The FieldEnv deals *only* with constructors defined in + -- *thie* module. For imported modules, we get the same info + -- from the TypeEnv \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 3217a95..49425a4 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -568,7 +568,8 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) kc_con_details (RecCon fields) = do { fields' <- mappM kc_field fields; return (RecCon fields') } - kc_field (HsRecField fld bty d) = do { bty' <- kc_larg_ty bty ; return (HsRecField fld bty' d) } + kc_field (ConDeclField fld bty d) = do { bty' <- kc_larg_ty bty + ; return (ConDeclField fld bty' d) } kc_larg_ty bty = case new_or_data of DataType -> kcHsSigType bty @@ -776,8 +777,8 @@ tcConDecl unbox_strict tycon tc_tvs -- Data types InfixCon bty1 bty2 -> tc_datacon True [] [bty1,bty2] RecCon fields -> tc_datacon False field_names btys where - (field_names, btys) = unzip [ (n, t) | HsRecField n t _ <- fields ] - + field_names = map cd_fld_name fields + btys = map cd_fld_type fields } tcResultType :: TyCon diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index 4035dc8..ba6e895 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -634,6 +634,13 @@ + + Enable record + field disambiguation + dynamic + + + or Enable foreign function interface (implied by ) diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 76a5844..4fbd08c 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -962,6 +962,48 @@ definitions; you must define such a function in prefix form. + +Record field disambiguation + +In record construction and record pattern matching +it is entirely unambiguous which field is referred to, even if there are two different +data types in scope with a common field name. For example: + +module M where + data S = MkS { x :: Int, y :: Bool } + +module Foo where + import M + + data T = MkT { x :: Int } + + ok1 (MkS { x = n }) = n+1 -- Unambiguous + + ok2 n = MkT { x = n+1 } -- Unambiguous + + bad1 k = k { x = 3 } -- Ambiguous + bad2 k = x k -- Ambiguous + +Even though there are two x's in scope, +it is clear that the x in the pattern in the +definition of ok1 can only mean the field +x from type S. Similarly for +the function ok2. However, in the record update +in bad1 and the record selection in bad2 +it is not clear which of the two types is intended. + + +Haskell 98 regards all four as ambiguous, but with the + flag, GHC will accept +the former two. The rules are precisely the same as those for instance +declarations in Haskell 98, where the method names on the left-hand side +of the method bindings in an instance declaration refer unambiguously +to the method of that class (provided they are in scope at all), even +if there are other variables in scope with the same name. +This reduces the clutter of qualified names when you import two +records from different modules that use the same field name. + + -- 1.7.10.4