diff options
author | Georgi Lyubenov <georgi.lyubenov@tweag.io> | 2022-09-09 15:24:03 +0300 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2023-02-21 18:35:56 -0500 |
commit | 172ff88fcac864a029d1cf77fbbe04c7a969d70d (patch) | |
tree | b13fbd18eea3ed72ba41b9ff825dc46836fc7f73 /compiler | |
parent | 8e765affde37197a6ebc174653171195fcc53003 (diff) | |
download | haskell-172ff88fcac864a029d1cf77fbbe04c7a969d70d.tar.gz |
GHC proposal 496 - Nullary record wildcards
This patch implements GHC proposal 496, which allows record wildcards
to be used for nullary constructors, e.g.
data A = MkA1 | MkA2 { fld1 :: Int }
f :: A -> Int
f (MkA1 {..}) = 0
f (MkA2 {..}) = fld1
To achieve this, we add arity information to the record field
environment, so that we can accept a constructor which has no fields
while continuing to reject non-record constructors with more than 1
field. See Note [Nullary constructors and empty record wildcards],
as well as the more general overview in Note [Local constructor info in the renamer],
both in the newly introduced GHC.Types.ConInfo module.
Fixes #22161
Diffstat (limited to 'compiler')
-rw-r--r-- | compiler/GHC/Rename/Env.hs | 26 | ||||
-rw-r--r-- | compiler/GHC/Rename/Module.hs | 31 | ||||
-rw-r--r-- | compiler/GHC/Rename/Names.hs | 87 | ||||
-rw-r--r-- | compiler/GHC/Rename/Pat.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/Tc/Errors/Ppr.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Tc/Errors/Types.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Tc/Module.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/Tc/Types.hs | 21 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Monad.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/Types/ConInfo.hs | 82 | ||||
-rw-r--r-- | compiler/Language/Haskell/Syntax/Type.hs | 12 | ||||
-rw-r--r-- | compiler/ghc.cabal.in | 1 |
12 files changed, 224 insertions, 71 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 |