diff options
32 files changed, 335 insertions, 73 deletions
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index ec423d0087..830e1a0dcc 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -36,7 +36,7 @@ module GHC.Rename.Env ( lookupSigCtxtOccRn, lookupSigCtxtOccRnN, lookupInstDeclBndr, lookupFamInstName, - lookupConstructorFields, + lookupConstructorInfo, lookupConstructorFields, lookupGreAvailRn, @@ -105,6 +105,7 @@ import GHC.Types.FieldLabel import GHC.Data.Bag import GHC.Types.PkgQual import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import GHC.Types.ConInfo (ConInfo, conInfoFields, mkConInfo) {- ********************************************************* @@ -399,27 +400,34 @@ lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f GHC.Rename.Bind.rnM lookupFamInstName Nothing tc_rdr -- Family instance; tc_rdr is an *occurrence* = lookupLocatedOccRnConstr tc_rdr ------------------------------------------------ -lookupConstructorFields :: Name -> RnM [FieldLabel] --- Look up the fields of a given constructor +lookupConstructorInfo :: Name -> RnM ConInfo +-- Look up the info for 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 more details, see Note [Local constructor info in the renamer] -- -- * For constructors from imported modules, use the *type* environment -- since imported modules are already compiled, the info is conveniently -- right there -lookupConstructorFields con_name +lookupConstructorInfo con_name = do { this_mod <- getModule ; if nameIsLocalOrFrom this_mod con_name then - do { field_env <- getRecFieldEnv - ; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env) - ; return (lookupNameEnv field_env con_name `orElse` []) } + do { con_env <- getConEnv + ; let conInfo = lookupNameEnv con_env con_name + ; traceTc "lookupCF" (ppr con_name $$ ppr conInfo $$ ppr con_env) + -- we always info for all the constructors in the current module in GHC.Rename.mk_con_env + -- hence we should be able to look up the constructor in tcg_con_env if it's from the current module + ; return (conInfo `orElse` panic "GHC.Rename.Env.lookupConstructorInfo") } else do { con <- tcLookupConLike con_name ; traceTc "lookupCF 2" (ppr con) - ; return (conLikeFieldLabels con) } } + ; pure $ mkConInfo (conLikeArity con) (conLikeFieldLabels con) } } + +----------------------------------------------- +lookupConstructorFields :: Name -> RnM [FieldLabel] +lookupConstructorFields = fmap conInfoFields . lookupConstructorInfo -- In CPS style as `RnM r` is monadic diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index fd9792744c..29a12299c4 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -79,6 +80,7 @@ import Data.List.NonEmpty ( NonEmpty(..), head ) import Data.Maybe ( isNothing, fromMaybe, mapMaybe ) import qualified Data.Set as Set ( difference, fromList, toList, null ) import Data.Function ( on ) +import GHC.Types.ConInfo (ConInfo, mkConInfo, conInfoFields) {- | @rnSourceDecl@ "renames" declarations. It simultaneously performs dependency analysis and precedence parsing. @@ -2646,23 +2648,23 @@ extendPatSynEnv :: DuplicateRecordFields -> FieldSelectors -> HsValBinds GhcPs - -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do { names_with_fls <- new_ps val_decls - ; let pat_syn_bndrs = concat [ name: map flSelector fields + ; let pat_syn_bndrs = concat [ name : map flSelector (conInfoFields fields) | (name, fields) <- names_with_fls ] ; let avails = map avail (map fst names_with_fls) - ++ map availField (concatMap snd names_with_fls) + ++ map availField (concatMap (conInfoFields . snd) names_with_fls) ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env - ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls - final_gbl_env = gbl_env { tcg_field_env = field_env' } + ; let field_env' = extendNameEnvList (tcg_con_env gbl_env) names_with_fls + final_gbl_env = gbl_env { tcg_con_env = field_env' } ; restoreEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } where - new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])] + new_ps :: HsValBinds GhcPs -> TcM [(Name, ConInfo)] new_ps (ValBinds _ binds _) = foldrM new_ps' [] binds new_ps _ = panic "new_ps" new_ps' :: LHsBindLR GhcPs GhcPs - -> [(Name, [FieldLabel])] - -> TcM [(Name, [FieldLabel])] + -> [(Name, ConInfo)] + -> TcM [(Name, ConInfo)] new_ps' bind names | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n , psb_args = RecCon as }))) <- bind @@ -2670,11 +2672,20 @@ extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do { bnd_name <- newTopSrcBinder (L (l2l bind_loc) n) let field_occs = map ((\ f -> L (noAnnSrcSpan $ getLocA (foLabel f)) f) . recordPatSynField) as flds <- mapM (newRecordSelector dup_fields_ok has_sel [bnd_name]) field_occs - return ((bnd_name, flds): names) - | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind + let conInfo = + mkConInfo + (conDetailsArity length (RecCon as)) + flds + return ((bnd_name, conInfo): names) + | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n + , psb_args})) <- bind = do bnd_name <- newTopSrcBinder (L (la2na bind_loc) n) - return ((bnd_name, []): names) + let conInfo = + mkConInfo + (conDetailsArity length psb_args) + [] + return ((bnd_name, conInfo): names) | otherwise = return names diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 7cd47c724b..65bb2c92d2 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -64,12 +64,13 @@ import GHC.Types.Avail import GHC.Types.FieldLabel import GHC.Types.SourceFile import GHC.Types.SrcLoc as SrcLoc -import GHC.Types.Basic ( TopLevelFlag(..) ) +import GHC.Types.Basic ( Arity, TopLevelFlag(..) ) import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.HpcInfo import GHC.Types.Error import GHC.Types.PkgQual +import GHC.Types.ConInfo (ConInfo, mkConInfo) import GHC.Unit import GHC.Unit.Module.Warnings @@ -95,6 +96,7 @@ import qualified Data.List.NonEmpty as NE import Data.Function ( on ) import qualified Data.Set as S import Data.Foldable ( toList ) +import Data.Void ( Void ) import System.FilePath ((</>)) import System.IO @@ -936,11 +938,11 @@ getLocalNonValBinders fixity_env -- Force the field access so that tcg_env is not retained. The -- selector thunk optimisation doesn't kick-in, see #20139 - ; let !old_field_env = tcg_field_env tcg_env - -- Extend tcg_field_env with new fields (this used to be the + ; let !old_field_env = tcg_con_env tcg_env + -- Extend tcg_con_env with new fields (this used to be the -- work of extendRecordFieldEnv) field_env = extendNameEnvList old_field_env flds - envs = (tcg_env { tcg_field_env = field_env }, tcl_env) + envs = (tcg_env { tcg_con_env = field_env }, tcl_env) ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env]) ; return (envs, new_bndrs) } } @@ -955,39 +957,75 @@ getLocalNonValBinders fixity_env ; return (avail nm) } new_tc :: DuplicateRecordFields -> FieldSelectors -> LTyClDecl GhcPs - -> RnM (AvailInfo, [(Name, [FieldLabel])]) + -> RnM (AvailInfo, [(Name, ConInfo)]) new_tc dup_fields_ok has_sel tc_decl -- NOT for type/data instances = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl ; names@(main_name : sub_names) <- mapM (newTopSrcBinder . l2n) bndrs ; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds ; let fld_env = case unLoc tc_decl of - DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds' + DataDecl { tcdDataDefn = d } -> mk_con_env d names flds' _ -> [] ; return (availTC main_name names flds', fld_env) } - -- Calculate the mapping from constructor names to fields, which - -- will go in tcg_field_env. It's convenient to do this here where + -- Calculate the mapping from constructor names to arity and fields, which + -- will go in tcg_con_env. It's convenient to do this here where -- we are working with a single datatype definition. - mk_fld_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel] - -> [(Name, [FieldLabel])] - mk_fld_env d names flds = concatMap find_con_flds (dd_cons d) + -- For more details, see Note [Local constructor info in the renamer] + mk_con_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel] + -> [(Name, ConInfo)] + mk_con_env d names flds = concatMap find_con_flds (dd_cons d) where + find_con_flds :: GenLocated l (ConDecl GhcPs) -> [(Name, ConInfo)] find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr - , con_args = RecCon cdflds })) + , con_args = con_det })) = [( find_con_name rdr - , concatMap find_con_decl_flds (unLoc cdflds) )] + , con_det_con_info con_det + )] find_con_flds (L _ (ConDeclGADT { con_names = rdrs - , con_g_args = RecConGADT flds _ })) + , con_g_args = con_gadt_det })) = [ ( find_con_name rdr - , concatMap find_con_decl_flds (unLoc flds)) + , gadt_det_con_info con_gadt_det + ) | L _ rdr <- toList rdrs ] - find_con_flds _ = [] - find_con_name rdr = expectJust "getLocalNonValBinders/find_con_name" $ find (\ n -> nameOccName n == rdrNameOcc rdr) names + + con_det_con_info + :: HsConDetails Void (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))) (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]) + -> ConInfo + con_det_con_info con_det = + let + (arity, fields) = + case con_det of + PrefixCon _ args -> + (length args, []) + RecCon cdflds -> + ((find_con_decl_field_arity . unLoc) cdflds, concatMap find_con_decl_flds $ unLoc cdflds) + InfixCon _ _ -> + (2, []) + in + mkConInfo + arity + fields + + gadt_det_con_info :: HsConDeclGADTDetails GhcPs -> ConInfo + gadt_det_con_info con_gadt_det = + let + (arity, fields) = + case con_gadt_det of + PrefixConGADT args -> + (length args, []) + RecConGADT (L _ args) _ -> + (find_con_decl_field_arity args, concatMap find_con_decl_flds args) + in + mkConInfo + arity + fields + + find_con_decl_flds :: GenLocated l (ConDeclField GhcPs) -> [FieldLabel] find_con_decl_flds (L _ x) = map find_con_decl_fld (cd_fld_names x) @@ -996,14 +1034,17 @@ getLocalNonValBinders fixity_env find (\ fl -> flLabel fl == lbl) flds where lbl = FieldLabelString $ occNameFS (rdrNameOcc rdr) + find_con_decl_field_arity :: [GenLocated SrcSpanAnnA (ConDeclField GhcPs)] -> Arity + find_con_decl_field_arity = length . concatMap (cd_fld_names . unLoc) + new_assoc :: DuplicateRecordFields -> FieldSelectors -> LInstDecl GhcPs - -> RnM ([AvailInfo], [(Name, [FieldLabel])]) + -> RnM ([AvailInfo], [(Name, ConInfo)]) new_assoc _ _ (L _ (TyFamInstD {})) = return ([], []) -- type instances don't bind new names new_assoc dup_fields_ok has_sel (L _ (DataFamInstD _ d)) - = do { (avail, flds) <- new_di dup_fields_ok has_sel Nothing d - ; return ([avail], flds) } + = do { (avail, arityAndFlds) <- new_di dup_fields_ok has_sel Nothing d + ; return ([avail], arityAndFlds) } new_assoc dup_fields_ok has_sel (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty , cid_datafam_insts = adts }))) = do -- First, attempt to grab the name of the class from the instance. @@ -1032,7 +1073,7 @@ getLocalNonValBinders fixity_env pure (avails, concat fldss) new_di :: DuplicateRecordFields -> FieldSelectors -> Maybe Name -> DataFamInstDecl GhcPs - -> RnM (AvailInfo, [(Name, [FieldLabel])]) + -> RnM (AvailInfo, [(Name, ConInfo)]) new_di dup_fields_ok has_sel mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl }) = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl) ; let (bndrs, flds) = hsDataFamInstBinders dfid @@ -1040,11 +1081,11 @@ getLocalNonValBinders fixity_env ; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds ; let avail = availTC (unLoc main_name) sub_names flds' -- main_name is not bound here! - fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds' + fld_env = mk_con_env (feqn_rhs ti_decl) sub_names flds' ; return (avail, fld_env) } new_loc_di :: DuplicateRecordFields -> FieldSelectors -> Maybe Name -> LDataFamInstDecl GhcPs - -> RnM (AvailInfo, [(Name, [FieldLabel])]) + -> RnM (AvailInfo, [(Name, ConInfo)]) new_loc_di dup_fields_ok has_sel mb_cls (L _ d) = new_di dup_fields_ok has_sel mb_cls d newRecordSelector :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index 169c2e508c..ccfb77fbde 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -82,6 +82,7 @@ import Data.Maybe import Data.Ratio import GHC.Types.FieldLabel (DuplicateRecordFields(..)) import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import GHC.Types.ConInfo (ConInfo(..), conInfoFields) {- ********************************************************* @@ -809,8 +810,8 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) do { dd_flag <- xoptM LangExt.RecordWildCards ; checkErr dd_flag (needFlagDotDot ctxt) ; (rdr_env, lcl_env) <- getRdrEnvs - ; con_fields <- lookupConstructorFields con - ; when (null con_fields) (addErr (TcRnIllegalWildcardsInConstructor con)) + ; conInfo <- lookupConstructorInfo con + ; when (conInfo == ConHasPositionalArgs) (addErr (TcRnIllegalWildcardsInConstructor con)) ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds) -- For constructor uses (but not patterns) @@ -822,7 +823,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) (dot_dot_fields, dot_dot_gres) = unzip [ (fl, gre) - | fl <- con_fields + | fl <- conInfoFields conInfo , let lbl = mkVarOccFS (field_label $ flLabel fl) , not (lbl `elemOccSet` present_flds) , Just gre <- [lookupGRE_FieldLabel rdr_env fl] diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 02acd47e2e..017b29425c 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -251,8 +251,10 @@ instance Diagnostic TcRnMessage where -> mkSimpleDecorated $ text "character literal out of range: '\\" <> char c <> char '\'' TcRnIllegalWildcardsInConstructor con -> mkSimpleDecorated $ - vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con) - , nest 2 (text "The constructor has no labelled fields") ] + vcat [ text "Illegal `{..}' notation for constructor" <+> quotes (ppr con) + , nest 2 (text "Record wildcards may not be used for constructors with unlabelled fields.") + , nest 2 (text "Possible fix: Remove the `{..}' and add a match for each field of the constructor.") + ] TcRnIgnoringAnnotations anns -> mkSimpleDecorated $ text "Ignoring ANN annotation" <> plural anns <> comma diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 0420a4e498..108eba5ab0 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -591,7 +591,11 @@ data TcRnMessage where Examples(s): None - Test cases: None + Test cases: + rename/should_fail/T9815.hs + rename/should_fail/T9815b.hs + rename/should_fail/T9815ghci.hs + rename/should_fail/T9815bghci.hs -} TcRnIllegalWildcardsInConstructor :: !Name -> TcRnMessage diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index edfa5a9258..f877e006b8 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -157,6 +157,7 @@ import GHC.Types.SrcLoc import GHC.Types.SourceFile import GHC.Types.TyThing.Ppr ( pprTyThingInContext ) import GHC.Types.PkgQual +import GHC.Types.ConInfo (mkConInfo) import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.External @@ -2099,8 +2100,8 @@ runTcInteractive hsc_env thing_inside (extendFamInstEnvList (tcg_fam_inst_env gbl_env) ic_finsts) home_fam_insts - , tcg_field_env = mkNameEnv con_fields - -- setting tcg_field_env is necessary + , tcg_con_env = mkNameEnv con_fields + -- setting tcg_con_env is necessary -- to make RecordWildCards work (test: ghci049) , tcg_fix_env = ic_fix_env icxt , tcg_default = ic_default icxt @@ -2135,7 +2136,7 @@ runTcInteractive hsc_env thing_inside -- Putting the dfuns in the type_env -- is just to keep Core Lint happy - con_fields = [ (dataConName c, dataConFieldLabels c) + con_fields = [ (dataConName c, mkConInfo (dataConSourceArity c) (dataConFieldLabels c)) | ATyCon t <- top_ty_things , c <- tyConDataCons t ] diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 5625bad539..acf7a0e6af 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -40,7 +40,7 @@ module GHC.Tc.Types( FrontendResult(..), -- Renamer types - ErrCtxt, RecFieldEnv, pushErrCtxt, pushErrCtxtSameOrigin, + ErrCtxt, pushErrCtxt, pushErrCtxtSameOrigin, ImportAvails(..), emptyImportAvails, plusImportAvails, WhereFrom(..), mkModDeps, @@ -126,7 +126,6 @@ import GHC.Core.FamInstEnv import GHC.Core.Predicate import GHC.Types.Id ( idType, idName ) -import GHC.Types.FieldLabel ( FieldLabel ) import GHC.Types.Fixity.Env import GHC.Types.Annotations import GHC.Types.CompleteMatch @@ -146,6 +145,7 @@ import GHC.Types.Unique.FM import GHC.Types.Basic import GHC.Types.CostCentre.State import GHC.Types.HpcInfo +import GHC.Types.ConInfo (ConFieldEnv) import GHC.Data.IOEnv import GHC.Data.Bag @@ -167,8 +167,8 @@ import GHC.Builtin.Names ( isUnboundName ) import Data.Set ( Set ) import qualified Data.Set as S -import Data.Map ( Map ) import Data.Dynamic ( Dynamic ) +import Data.Map ( Map ) import Data.Typeable ( TypeRep ) import Data.Maybe ( mapMaybe ) import GHCi.Message @@ -443,8 +443,10 @@ data TcGblEnv -- ^ Types used for defaulting. @Nothing@ => no @default@ decl tcg_fix_env :: FixityEnv, -- ^ Just for things in this module - tcg_field_env :: RecFieldEnv, -- ^ Just for things in this module - -- See Note [The interactive package] in "GHC.Runtime.Context" + tcg_con_env :: ConFieldEnv, + -- ^ Just for things in this module + -- For information on why this is necessary, see Note [Local constructor info in the renamer] + -- See Note [The interactive package] in "GHC.Runtime.Context" tcg_type_env :: TypeEnv, -- ^ Global type env for the module we are compiling now. All @@ -687,15 +689,6 @@ tcVisibleOrphanMods tcg_env instance ContainsModule TcGblEnv where extractModule env = tcg_semantic_mod env -type RecFieldEnv = NameEnv [FieldLabel] - -- 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 *this* - -- module. For imported modules, we get the same info from the - -- TypeEnv - data SelfBootInfo = NoSelfBoot -- No corresponding hi-boot file | SelfBoot diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index ecd3ab3249..a8ab977def 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -55,7 +55,7 @@ module GHC.Tc.Utils.Monad( getIsGHCi, getGHCiMonad, getInteractivePrintName, tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv, getRdrEnvs, getImports, - getFixityEnv, extendFixityEnv, getRecFieldEnv, + getFixityEnv, extendFixityEnv, getConEnv, getDeclaredDefaultTys, addDependentFiles, @@ -209,6 +209,7 @@ import GHC.Types.Annotations import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) ) import GHC.Types.CostCentre.State import GHC.Types.SourceFile +import GHC.Types.ConInfo (ConFieldEnv) import qualified GHC.LanguageExtensions as LangExt @@ -300,7 +301,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_src = hsc_src, tcg_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv, - tcg_field_env = emptyNameEnv, + tcg_con_env = emptyNameEnv, tcg_default = if moduleUnit mod == primUnit || moduleUnit mod == bignumUnit then Just [] -- See Note [Default types] @@ -942,8 +943,8 @@ 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) } +getConEnv :: TcRn ConFieldEnv +getConEnv = do { env <- getGblEnv; return (tcg_con_env env) } getDeclaredDefaultTys :: TcRn (Maybe [Type]) getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } diff --git a/compiler/GHC/Types/ConInfo.hs b/compiler/GHC/Types/ConInfo.hs new file mode 100644 index 0000000000..b89ce2632d --- /dev/null +++ b/compiler/GHC/Types/ConInfo.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DerivingStrategies #-} +module GHC.Types.ConInfo ( + ConFieldEnv, ConInfo(..), mkConInfo, conInfoFields, + ) where + +import GHC.Prelude +import GHC.Types.Name.Env (NameEnv) +import Data.List.NonEmpty (NonEmpty) +import GHC.Types.FieldLabel ( FieldLabel ) +import qualified Data.List.NonEmpty as NonEmpty +import GHC.Types.Basic (Arity) +import GHC.Utils.Outputable (Outputable(..), text, (<+>), equals, braces, (<>)) + +{- Note [Local constructor info in the renamer] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During renaming, we need certain information about constructors. + +While we can use TypeEnv to get this info for constructors from imported modules, +the same cannot be done for constructors defined in the module +that we are currently renaming, as they have not been type checked yet. + +Hence, we use ConFieldEnv to store the minimal information required to proceed +with renaming, getting it from the parse tree. + +For example, consider + data T = T1 { x, y :: Int } + | T2 { x :: Int } + | T3 + | T4 Int Bool + +Specifically we need to know: +* The fields of the data constructor, so that + - We can complain if you say `T1 { v = 3 }`, where `v` is not a field of `T1` + See the following call stack + * GHC.Rename.Expr.rnExpr (RecordCon case) + * GHC.Rename.Pat.rnHsRecFields + * GHC.Rename.Env.lookupRecFieldOcc + - Ditto if you pattern match on `T1 { v = x }`. + See the following call stack + * GHC.Rename.Pat.rnHsRecPatsAndThen + * GHC.Rename.Pat.rnHsRecFields + * GHC.Rename.Env.lookupRecFieldOcc + - We can fill in the dots if you say `T1 {..}` in construction or pattern matching + See GHC.Rename.Pat.rnHsRecFields.rn_dotdot + +* Whether the contructor is nullary. + We need to know this to accept `T2 {..}`, and `T3 {..}`, but reject `T4 {..}`, + in both construction and pattern matching. + See GHC.Rename.Pat.rnHsRecFields.rn_dotdot + and Note [Nullary constructors and empty record wildcards] + +Note [Nullary constructors and empty record wildcards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A nullary constructor is one with no arguments. +For example, both `data T = MkT` and `data T = MkT {}` are nullary. + +For consistency and TH convenience, it was agreed that a `{..}` +match or usage on nullary constructors would be accepted. +This is done as as per https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0496-empty-record-wildcards.rst +-} +type ConFieldEnv = NameEnv ConInfo + +-- | See Note [Local constructor info in the renamer] +data ConInfo + = ConHasRecordFields (NonEmpty FieldLabel) + | ConHasPositionalArgs + | ConIsNullary + deriving stock Eq + +mkConInfo :: Arity -> [FieldLabel] -> ConInfo +mkConInfo 0 _ = ConIsNullary +mkConInfo _ fields = maybe ConHasPositionalArgs ConHasRecordFields $ NonEmpty.nonEmpty fields + +conInfoFields :: ConInfo -> [FieldLabel] +conInfoFields (ConHasRecordFields fields) = NonEmpty.toList fields +conInfoFields ConHasPositionalArgs = [] +conInfoFields ConIsNullary = [] + +instance Outputable ConInfo where + ppr ConIsNullary = text "ConIsNullary" + ppr ConHasPositionalArgs = text "ConHasPositionalArgs" + ppr (ConHasRecordFields fieldLabels) = text "ConHasRecordFields" <> braces (text "fieldLabels" <+> equals <+> ppr fieldLabels) diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs index 8898d2400b..fa57f9d2ef 100644 --- a/compiler/Language/Haskell/Syntax/Type.hs +++ b/compiler/Language/Haskell/Syntax/Type.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] +{-# LANGUAGE LambdaCase #-} -- in module Language.Haskell.Syntax.Extension {- (c) The University of Glasgow 2006 @@ -44,7 +45,7 @@ module Language.Haskell.Syntax.Type ( ConDeclField(..), LConDeclField, - HsConDetails(..), noTypeArgs, + HsConDetails(..), noTypeArgs, conDetailsArity, FieldOcc(..), LFieldOcc, AmbiguousFieldOcc(..), LAmbiguousFieldOcc, @@ -64,6 +65,7 @@ import GHC.Types.Name.Reader ( RdrName ) import GHC.Core.DataCon( HsSrcBang(..) ) import GHC.Core.Type (Specificity) import GHC.Types.SrcLoc (SrcSpan) +import GHC.Types.Basic (Arity) import GHC.Hs.Doc (LHsDoc) import GHC.Data.FastString (FastString) @@ -74,7 +76,7 @@ import Data.Maybe import Data.Eq import Data.Bool import Data.Char -import Prelude (Integer) +import Prelude (Integer, length) {- ************************************************************************ @@ -1072,6 +1074,12 @@ data HsConDetails tyarg arg rec noTypeArgs :: [Void] noTypeArgs = [] +conDetailsArity :: (rec -> Arity) -> HsConDetails tyarg arg rec -> Arity +conDetailsArity recToArity = \case + PrefixCon _ args -> length args + RecCon rec -> recToArity rec + InfixCon _ _ -> 2 + {- Note [ConDeclField pass] ~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index cb3d82e591..74384caf49 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -751,6 +751,7 @@ Library GHC.Types.Basic GHC.Types.BreakInfo GHC.Types.CompleteMatch + GHC.Types.ConInfo GHC.Types.CostCentre GHC.Types.CostCentre.State GHC.Types.Cpr diff --git a/docs/users_guide/9.8.1-notes.rst b/docs/users_guide/9.8.1-notes.rst index f836f62320..503105472e 100644 --- a/docs/users_guide/9.8.1-notes.rst +++ b/docs/users_guide/9.8.1-notes.rst @@ -21,6 +21,12 @@ Compiler foo (\x -> x*2 + x) +- GHC Proposal `#496 + <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0496-empty-record-wildcards.rst>`_ + has been implemented, allowing ``{..}`` syntax for constructors without fields, for consistency. + This is convenient for TH code generation, as you can now uniformly use record wildcards + regardless of number of fields. + GHCi ~~~~ diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index cdc15da1ca..efd58af99f 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -201,6 +201,7 @@ GHC.Types.Avail GHC.Types.Basic GHC.Types.BreakInfo GHC.Types.CompleteMatch +GHC.Types.ConInfo GHC.Types.CostCentre GHC.Types.CostCentre.State GHC.Types.Cpr diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index 8256bb8add..f1116f5198 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -208,6 +208,7 @@ GHC.Types.Avail GHC.Types.Basic GHC.Types.BreakInfo GHC.Types.CompleteMatch +GHC.Types.ConInfo GHC.Types.CostCentre GHC.Types.CostCentre.State GHC.Types.Cpr diff --git a/testsuite/tests/rename/should_compile/GADTNullaryRecordRecordWildcard.hs b/testsuite/tests/rename/should_compile/GADTNullaryRecordRecordWildcard.hs new file mode 100644 index 0000000000..0c706d1209 --- /dev/null +++ b/testsuite/tests/rename/should_compile/GADTNullaryRecordRecordWildcard.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE RecordWildCards #-} + +module GADTNullaryRecordRecordWildcard where + +data X a where + X :: {} -> X a + +f X {..} = () diff --git a/testsuite/tests/rename/should_compile/GADTNullaryRecordWildcard.hs b/testsuite/tests/rename/should_compile/GADTNullaryRecordWildcard.hs new file mode 100644 index 0000000000..1181427485 --- /dev/null +++ b/testsuite/tests/rename/should_compile/GADTNullaryRecordWildcard.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE RecordWildCards #-} + +module GADTNullaryRecordWildcard where + +data X a where + X :: X a + +f X {..} = () diff --git a/testsuite/tests/rename/should_compile/GADTSymbolicRecordRecordWildcard.hs b/testsuite/tests/rename/should_compile/GADTSymbolicRecordRecordWildcard.hs new file mode 100644 index 0000000000..f69d5a6aa2 --- /dev/null +++ b/testsuite/tests/rename/should_compile/GADTSymbolicRecordRecordWildcard.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE RecordWildCards #-} + +module GADTSymbolicRecordRecordWildcard where + +data G a where + (:&) :: {fld1 :: Int, fld2 :: a} -> G a + +f :: G Int -> Int +f (:&) {..} = fld1 + fld2 diff --git a/testsuite/tests/rename/should_compile/GHCIImplicitImportNullaryRecordWildcard.script b/testsuite/tests/rename/should_compile/GHCIImplicitImportNullaryRecordWildcard.script new file mode 100644 index 0000000000..5e8740424b --- /dev/null +++ b/testsuite/tests/rename/should_compile/GHCIImplicitImportNullaryRecordWildcard.script @@ -0,0 +1,3 @@ +:set -XRecordWildCards + +f x = GHC.Generics.U1 {..} diff --git a/testsuite/tests/rename/should_compile/GHCINullaryRecordWildcard.script b/testsuite/tests/rename/should_compile/GHCINullaryRecordWildcard.script new file mode 100644 index 0000000000..56c6f062f1 --- /dev/null +++ b/testsuite/tests/rename/should_compile/GHCINullaryRecordWildcard.script @@ -0,0 +1,5 @@ +:set -XRecordWildCards + +data Foo = Foo + +f Foo {..} = Foo {..} diff --git a/testsuite/tests/rename/should_compile/ImportNullaryRecordWildcard.hs b/testsuite/tests/rename/should_compile/ImportNullaryRecordWildcard.hs new file mode 100644 index 0000000000..0746eae29b --- /dev/null +++ b/testsuite/tests/rename/should_compile/ImportNullaryRecordWildcard.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE RecordWildCards #-} + +module ImportNullaryRecordWildcard where + +import NullaryRecordWildcard as A +import NullaryRecordRecordWildcard as B + +g A.X {..} = () + +h B.X {..} = () diff --git a/testsuite/tests/rename/should_compile/NullaryRecordRecordWildcard.hs b/testsuite/tests/rename/should_compile/NullaryRecordRecordWildcard.hs new file mode 100644 index 0000000000..86fe464268 --- /dev/null +++ b/testsuite/tests/rename/should_compile/NullaryRecordRecordWildcard.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RecordWildCards #-} + +module NullaryRecordRecordWildcard where + +data X = X { } + +f X {..} = () diff --git a/testsuite/tests/rename/should_compile/NullaryRecordWildcard.hs b/testsuite/tests/rename/should_compile/NullaryRecordWildcard.hs new file mode 100644 index 0000000000..ab3e3fbe7e --- /dev/null +++ b/testsuite/tests/rename/should_compile/NullaryRecordWildcard.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE RecordWildCards #-} + +module NullaryRecordWildcard where + +data X = X + +f X {..} = () diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T index 673cdf8c78..ba05c88357 100644 --- a/testsuite/tests/rename/should_compile/all.T +++ b/testsuite/tests/rename/should_compile/all.T @@ -200,3 +200,11 @@ test('T22513g', normal, compile, ['-Wterm-variable-capture']) test('T22513h', normal, compile, ['-Wterm-variable-capture']) test('T22513i', req_th, compile, ['-Wterm-variable-capture']) test('T22913', normal, compile, ['']) +test('NullaryRecordWildcard', normal, compile, ['']) +test('GADTNullaryRecordWildcard', normal, compile, ['']) +test('NullaryRecordRecordWildcard', normal, compile, ['']) +test('GADTNullaryRecordRecordWildcard', normal, compile, ['']) +test('GADTSymbolicRecordRecordWildcard', normal, compile, ['']) +test('ImportNullaryRecordWildcard', [extra_files(['NullaryRecordWildcard.hs', 'NullaryRecordRecordWildcard.hs'])], multimod_compile, ['ImportNullaryRecordWildcard', '-v0']) +test('GHCINullaryRecordWildcard', combined_output, ghci_script, ['GHCINullaryRecordWildcard.script']) +test('GHCIImplicitImportNullaryRecordWildcard', combined_output, ghci_script, ['GHCIImplicitImportNullaryRecordWildcard.script']) diff --git a/testsuite/tests/rename/should_fail/T9815.stderr b/testsuite/tests/rename/should_fail/T9815.stderr index 77b02eff6f..4f19bd115f 100644 --- a/testsuite/tests/rename/should_fail/T9815.stderr +++ b/testsuite/tests/rename/should_fail/T9815.stderr @@ -1,4 +1,5 @@ T9815.hs:6:13: error: [GHC-47217] - Illegal `..' notation for constructor ‘N’ - The constructor has no labelled fields + Illegal `{..}' notation for constructor ‘N’ + Record wildcards may not be used for constructors with unlabelled fields. + Possible fix: Remove the `{..}' and add a match for each field of the constructor. diff --git a/testsuite/tests/rename/should_fail/T9815b.hs b/testsuite/tests/rename/should_fail/T9815b.hs new file mode 100644 index 0000000000..a61c43303d --- /dev/null +++ b/testsuite/tests/rename/should_fail/T9815b.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE RecordWildCards #-} +module T9815b where + +import T9815 + +bar = print N{..} diff --git a/testsuite/tests/rename/should_fail/T9815b.stderr b/testsuite/tests/rename/should_fail/T9815b.stderr new file mode 100644 index 0000000000..4f19bd115f --- /dev/null +++ b/testsuite/tests/rename/should_fail/T9815b.stderr @@ -0,0 +1,5 @@ + +T9815.hs:6:13: error: [GHC-47217] + Illegal `{..}' notation for constructor ‘N’ + Record wildcards may not be used for constructors with unlabelled fields. + Possible fix: Remove the `{..}' and add a match for each field of the constructor. diff --git a/testsuite/tests/rename/should_fail/T9815bghci.script b/testsuite/tests/rename/should_fail/T9815bghci.script new file mode 100644 index 0000000000..5a07f142d9 --- /dev/null +++ b/testsuite/tests/rename/should_fail/T9815bghci.script @@ -0,0 +1,5 @@ +:set -XRecordWildCards + +data Arg = Arg () Bool + +f x = Arg {..} diff --git a/testsuite/tests/rename/should_fail/T9815bghci.stderr b/testsuite/tests/rename/should_fail/T9815bghci.stderr new file mode 100644 index 0000000000..9d267cf5fb --- /dev/null +++ b/testsuite/tests/rename/should_fail/T9815bghci.stderr @@ -0,0 +1,5 @@ + +<interactive>:5:7: [GHC-47217] + Illegal `{..}' notation for constructor ‘Arg’ + Record wildcards may not be used for constructors with unlabelled fields. + Possible fix: Remove the `{..}' and add a match for each field of the constructor. diff --git a/testsuite/tests/rename/should_fail/T9815ghci.script b/testsuite/tests/rename/should_fail/T9815ghci.script new file mode 100644 index 0000000000..3e748c76ae --- /dev/null +++ b/testsuite/tests/rename/should_fail/T9815ghci.script @@ -0,0 +1,3 @@ +:set -XRecordWildCards + +f x = Data.Semigroup.Arg {..} diff --git a/testsuite/tests/rename/should_fail/T9815ghci.stderr b/testsuite/tests/rename/should_fail/T9815ghci.stderr new file mode 100644 index 0000000000..c4f4a91d23 --- /dev/null +++ b/testsuite/tests/rename/should_fail/T9815ghci.stderr @@ -0,0 +1,5 @@ + +<interactive>:3:7: [GHC-47217] + Illegal `{..}' notation for constructor ‘Data.Semigroup.Arg’ + Record wildcards may not be used for constructors with unlabelled fields. + Possible fix: Remove the `{..}' and add a match for each field of the constructor. diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T index e15b13e9e3..6234f4a85d 100644 --- a/testsuite/tests/rename/should_fail/all.T +++ b/testsuite/tests/rename/should_fail/all.T @@ -110,6 +110,9 @@ test('T9436', normal, compile_fail, ['']) test('T9437', normal, compile_fail, ['']) test('T9077', normal, compile_fail, ['']) test('T9815', normal, compile_fail, ['']) +test('T9815b', [extra_files(['T9815.hs'])], multimod_compile_fail, ['T9815b', '-v0']) +test('T9815ghci', normal, ghci_script, ['T9815ghci.script']) +test('T9815bghci', normal, ghci_script, ['T9815bghci.script']) test('T9032', normal, |