From c1f81b38625a5fea7fb8160a3a62ae6be078a7b1 Mon Sep 17 00:00:00 2001 From: M Farkas-Dyck Date: Sun, 13 Mar 2022 16:10:21 -0800 Subject: Scrub partiality about `NewOrData`. Rather than a list of constructors and a `NewOrData` flag, we define `data DataDefnCons a = NewTypeCon a | DataTypeCons [a]`, which enforces a newtype to have exactly one constructor. Closes #22070. Bump haddock submodule. --- compiler/GHC/Hs/Decls.hs | 78 +++++++++++-------- compiler/GHC/Hs/Utils.hs | 5 +- compiler/GHC/HsToCore/Docs.hs | 7 +- compiler/GHC/HsToCore/Errors/Ppr.hs | 4 - compiler/GHC/HsToCore/Errors/Types.hs | 2 - compiler/GHC/HsToCore/Quote.hs | 18 +++-- compiler/GHC/Iface/Ext/Ast.hs | 19 ++++- compiler/GHC/Parser.y | 10 +-- compiler/GHC/Parser/Errors/Ppr.hs | 8 ++ compiler/GHC/Parser/Errors/Types.hs | 2 + compiler/GHC/Parser/PostProcess.hs | 23 ++++-- compiler/GHC/Parser/PostProcess/Haddock.hs | 5 +- compiler/GHC/Rename/Module.hs | 23 +++--- compiler/GHC/Rename/Names.hs | 3 +- compiler/GHC/Rename/Utils.hs | 18 +++-- compiler/GHC/Tc/TyCl.hs | 116 ++++++++++++++--------------- compiler/GHC/Tc/TyCl/Instance.hs | 20 ++--- compiler/GHC/ThToHs.hs | 37 +++++---- compiler/GHC/Types/Error/Codes.hs | 2 +- compiler/GHC/Utils/Monad.hs | 3 +- 20 files changed, 222 insertions(+), 181 deletions(-) (limited to 'compiler/GHC') diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index 8bb7834f3b..1db54bfc4b 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -27,7 +27,7 @@ module GHC.Hs.Decls ( -- * Toplevel declarations HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys, - NewOrData(..), newOrDataToFlavour, + NewOrData, newOrDataToFlavour, anyLConIsGadt, StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName, -- ** Class or type declarations @@ -43,7 +43,8 @@ module GHC.Hs.Decls ( tyClDeclLName, tyClDeclTyVars, hsDeclHasCusk, famResultKindSignature, FamilyDecl(..), LFamilyDecl, - FunDep(..), + FunDep(..), ppDataDefnHeader, + pp_vanilla_decl_head, -- ** Instance declarations InstDecl(..), LInstDecl, FamilyInfo(..), @@ -132,6 +133,7 @@ import GHC.Types.ForeignCall import GHC.Data.Bag import GHC.Data.Maybe import Data.Data (Data) +import Data.Foldable (toList) {- ************************************************************************ @@ -399,10 +401,10 @@ countTyClDecls decls count isNewTy decls, -- ...instances count isFamilyDecl decls) where - isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True + isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_cons = DataTypeCons _ } } = True isDataTy _ = False - isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True + isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_cons = NewTypeCon _ } } = True isNewTy _ = False -- FIXME: tcdName is commonly used by both GHC and third-party tools, so it @@ -501,8 +503,8 @@ pprTyClDeclFlavour (ClassDecl {}) = text "class" pprTyClDeclFlavour (SynDecl {}) = text "type" pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) = pprFlavour info <+> text "family" -pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) - = ppr nd +pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = nd } }) + = ppr (dataDefnConsNewOrData nd) instance OutputableBndrId p => Outputable (FunDep (GhcPass p)) where ppr = pprFunDep @@ -665,9 +667,10 @@ type instance XConDeclH98 (GhcPass _) = EpAnn [AddEpAnn] type instance XXConDecl (GhcPass _) = DataConCantHappen +-- Codomain could be 'NonEmpty', but at the moment all users need a list. getConNames :: ConDecl GhcRn -> [LocatedN Name] getConNames ConDeclH98 {con_name = name} = [name] -getConNames ConDeclGADT {con_names = names} = names +getConNames ConDeclGADT {con_names = names} = toList names -- | Return @'Just' fields@ if a data constructor declaration uses record -- syntax (i.e., 'RecCon'), where @fields@ are the field selectors. @@ -685,28 +688,38 @@ hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)] hsConDeclTheta Nothing = [] hsConDeclTheta (Just (L _ theta)) = theta +ppDataDefnHeader + :: (OutputableBndrId p) + => (Maybe (LHsContext (GhcPass p)) -> SDoc) -- Printing the header + -> HsDataDefn (GhcPass p) + -> SDoc +ppDataDefnHeader pp_hdr HsDataDefn + { dd_ctxt = context + , dd_cType = mb_ct + , dd_kindSig = mb_sig + , dd_cons = condecls } + = ppr (dataDefnConsNewOrData condecls) <+> pp_ct <+> pp_hdr context <+> pp_sig + where + pp_ct = case mb_ct of + Nothing -> empty + Just ct -> ppr ct + pp_sig = case mb_sig of + Nothing -> empty + Just kind -> dcolon <+> ppr kind + pp_data_defn :: (OutputableBndrId p) => (Maybe (LHsContext (GhcPass p)) -> SDoc) -- Printing the header -> HsDataDefn (GhcPass p) -> SDoc -pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context - , dd_cType = mb_ct - , dd_kindSig = mb_sig - , dd_cons = condecls, dd_derivs = derivings }) +pp_data_defn pp_hdr defn@HsDataDefn + { dd_cons = condecls + , dd_derivs = derivings } | null condecls - = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig - <+> pp_derivings derivings + = ppDataDefnHeader pp_hdr defn <+> pp_derivings derivings | otherwise - = hang (ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig) - 2 (pp_condecls condecls $$ pp_derivings derivings) + = hang (ppDataDefnHeader pp_hdr defn) 2 (pp_condecls (toList condecls) $$ pp_derivings derivings) where - pp_ct = case mb_ct of - Nothing -> empty - Just ct -> ppr ct - pp_sig = case mb_sig of - Nothing -> empty - Just kind -> dcolon <+> ppr kind pp_derivings ds = vcat (map ppr ds) instance OutputableBndrId p @@ -720,15 +733,10 @@ instance OutputableBndrId p pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc pp_condecls cs - | gadt_syntax -- In GADT syntax + | anyLConIsGadt cs -- In GADT syntax = hang (text "where") 2 (vcat (map ppr cs)) | otherwise -- In H98 syntax = equals <+> sep (punctuate (text " |") (map ppr cs)) - where - gadt_syntax = case cs of - [] -> False - (L _ ConDeclH98{} : _) -> False - (L _ ConDeclGADT{} : _) -> True instance (OutputableBndrId p) => Outputable (ConDecl (GhcPass p)) where ppr = pprConDecl @@ -756,7 +764,7 @@ pprConDecl (ConDeclH98 { con_name = L _ con pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty, con_doc = doc }) - = pprMaybeWithDoc doc $ ppr_con_names cons <+> dcolon + = pprMaybeWithDoc doc $ ppr_con_names (toList cons) <+> dcolon <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt, sep (ppr_args args ++ [ppr res_ty]) ]) where @@ -850,9 +858,9 @@ pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = -- pp_data_defn pretty-prints the kind sig. See #14817. pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc -pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = - (FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }})}) - = ppr nd +pprDataFamInstFlavour DataFamInstDecl + { dfid_eqn = FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons }}} + = ppr (dataDefnConsNewOrData cons) pprHsFamInstLHS :: (OutputableBndrId p) => IdP (GhcPass p) @@ -932,6 +940,14 @@ instance Outputable NewOrData where ppr NewType = text "newtype" ppr DataType = text "data" +-- At the moment we only call this with @f = '[]'@ and @f = 'DataDefnCons'@. +anyLConIsGadt :: Foldable f => f (GenLocated l (ConDecl pass)) -> Bool +anyLConIsGadt xs = case toList xs of + L _ ConDeclGADT {} : _ -> True + _ -> False +{-# SPECIALIZE anyLConIsGadt :: [GenLocated l (ConDecl pass)] -> Bool #-} +{-# SPECIALIZE anyLConIsGadt :: DataDefnCons (GenLocated l (ConDecl pass)) -> Bool #-} + {- ************************************************************************ * * diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 3e74eea3db..195df82d8a 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -147,6 +147,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import Data.Either +import Data.Foldable ( toList ) import Data.Function import Data.List ( partition, deleteBy ) @@ -1439,7 +1440,7 @@ hsDataDefnBinders :: IsPass p => HsDataDefn (GhcPass p) -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsDataDefnBinders (HsDataDefn { dd_cons = cons }) - = hsConDeclsBinders cons + = hsConDeclsBinders (toList cons) -- See Note [Binders in family instances] ------------------- @@ -1466,7 +1467,7 @@ hsConDeclsBinders cons -- remove only the first occurrence of any seen field in order to -- avoid circumventing detection of duplicate fields (#9156) ConDeclGADT { con_names = names, con_g_args = args } - -> (map (L loc . unLoc) names ++ ns, flds ++ fs) + -> (toList (L loc . unLoc <$> names) ++ ns, flds ++ fs) where (remSeen', flds) = get_flds_gadt remSeen args (ns, fs) = go remSeen' rs diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs index f8436fecd8..f162dadaf5 100644 --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -28,6 +28,7 @@ import GHC.Parser.Annotation import Control.Applicative import Control.Monad.IO.Class import Data.Bifunctor (first) +import Data.Foldable (toList) import Data.IntMap (IntMap) import qualified Data.IntMap as IM import Data.Map.Strict (Map) @@ -366,13 +367,13 @@ subordinates env instMap decl = case decl of -> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))] dataSubs dd = constrs ++ fields ++ derivs where - cons = map unLoc $ (dd_cons dd) + cons = unLoc <$> dd_cons dd constrs = [ ( unLoc cname , maybeToList $ fmap unLoc $ con_doc c , conArgDocs c) - | c <- cons, cname <- getConNames c ] + | c <- toList cons, cname <- getConNames c ] fields = [ (foExt n, maybeToList $ fmap unLoc doc, IM.empty) - | Just flds <- map getRecConArgs_maybe cons + | Just flds <- toList $ fmap getRecConArgs_maybe cons , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) , (L _ n) <- ns ] derivs = [ (instName, [unLoc doc], IM.empty) diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs index ede0e6febf..092a690b25 100644 --- a/compiler/GHC/HsToCore/Errors/Ppr.hs +++ b/compiler/GHC/HsToCore/Errors/Ppr.hs @@ -114,8 +114,6 @@ instance Diagnostic DsMessage where | isTyVar b = text "type variable" <+> quotes (ppr b) | isEvVar b = text "constraint" <+> quotes (ppr (varType b)) | otherwise = text "variable" <+> quotes (ppr b) - DsMultipleConForNewtype names - -> mkSimpleDecorated $ text "Multiple constructors for newtype:" <+> pprQuotedList names DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs -> mkSimpleDecorated $ hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$ @@ -226,7 +224,6 @@ instance Diagnostic DsMessage where DsRuleLhsTooComplicated{} -> WarningWithoutFlag DsRuleIgnoredDueToConstructor{} -> WarningWithoutFlag DsRuleBindersNotBound{} -> WarningWithoutFlag - DsMultipleConForNewtype{} -> ErrorWithoutFlag DsLazyPatCantBindVarsOfUnliftedType{} -> ErrorWithoutFlag DsNotYetHandledByTH{} -> ErrorWithoutFlag DsAggregatedViewExpressions{} -> WarningWithoutFlag @@ -263,7 +260,6 @@ instance Diagnostic DsMessage where DsRuleLhsTooComplicated{} -> noHints DsRuleIgnoredDueToConstructor{} -> noHints DsRuleBindersNotBound{} -> noHints - DsMultipleConForNewtype{} -> noHints DsLazyPatCantBindVarsOfUnliftedType{} -> noHints DsNotYetHandledByTH{} -> noHints DsAggregatedViewExpressions{} -> noHints diff --git a/compiler/GHC/HsToCore/Errors/Types.hs b/compiler/GHC/HsToCore/Errors/Types.hs index 1b1c5532f8..028a02544d 100644 --- a/compiler/GHC/HsToCore/Errors/Types.hs +++ b/compiler/GHC/HsToCore/Errors/Types.hs @@ -122,8 +122,6 @@ data DsMessage !CoreExpr -- ^ The optimised LHS - | DsMultipleConForNewtype [LocatedN Name] - | DsLazyPatCantBindVarsOfUnliftedType [Var] | DsNotYetHandledByTH !ThRejectionReason diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index ac122446b7..e6f8ce4c51 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -98,6 +98,7 @@ import Data.List.NonEmpty ( NonEmpty(..) ) import Data.Function import Control.Monad.Trans.Reader import Control.Monad.Trans.Class +import Data.Foldable ( toList ) data MetaWrappers = MetaWrappers { -- Applies its argument to a type argument `m` and dictionary `Quote m` @@ -517,17 +518,16 @@ repDataDefn :: Core TH.Name -> HsDataDefn GhcRn -> MetaM (Core (M TH.Dec)) repDataDefn tc opts - (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig + (HsDataDefn { dd_ctxt = cxt, dd_kindSig = ksig , dd_cons = cons, dd_derivs = mb_derivs }) = do { cxt1 <- repLContext cxt ; derivs1 <- repDerivs mb_derivs - ; case (new_or_data, cons) of - (NewType, [con]) -> do { con' <- repC con + ; case cons of + NewTypeCon con -> do { con' <- repC con ; ksig' <- repMaybeLTy ksig ; repNewtype cxt1 tc opts ksig' con' derivs1 } - (NewType, _) -> lift $ failWithDs (DsMultipleConForNewtype (getConNames $ unLoc $ head cons)) - (DataType, _) -> do { ksig' <- repMaybeLTy ksig + DataTypeCons cons -> do { ksig' <- repMaybeLTy ksig ; consL <- mapM repC cons ; cons1 <- coreListM conTyConName consL ; repData cxt1 tc opts ksig' cons1 @@ -2704,7 +2704,7 @@ repH98DataCon con details arg_vtys <- repRecConArgs ips rep2 recCName [unC con', unC arg_vtys] -repGadtDataCons :: [LocatedN Name] +repGadtDataCons :: NonEmpty (LocatedN Name) -> HsConDeclGADTDetails GhcRn -> LHsType GhcRn -> MetaM (Core (M TH.Con)) @@ -2714,11 +2714,11 @@ repGadtDataCons cons details res_ty PrefixConGADT ps -> do arg_tys <- repPrefixConArgs ps res_ty' <- repLTy res_ty - rep2 gadtCName [ unC (nonEmptyCoreList cons'), unC arg_tys, unC res_ty'] + rep2 gadtCName [ unC (nonEmptyCoreList' cons'), unC arg_tys, unC res_ty'] RecConGADT ips _ -> do arg_vtys <- repRecConArgs ips res_ty' <- repLTy res_ty - rep2 recGadtCName [unC (nonEmptyCoreList cons'), unC arg_vtys, + rep2 recGadtCName [unC (nonEmptyCoreList' cons'), unC arg_vtys, unC res_ty'] -- TH currently only supports linear constructors. @@ -3001,6 +3001,8 @@ nonEmptyCoreList :: [Core a] -> Core [a] nonEmptyCoreList [] = panic "coreList: empty argument" nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) +nonEmptyCoreList' :: NonEmpty (Core a) -> Core [a] +nonEmptyCoreList' xs@(MkC x:|_) = MkC (mkListExpr (exprType x) (toList $ fmap unC xs)) coreStringLit :: MonadThings m => String -> m (Core String) coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index de66cdaef2..61a88fc4c7 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -69,7 +69,9 @@ import qualified Data.ByteString as BS import qualified Data.Map as M import qualified Data.Set as S import Data.Data ( Data, Typeable ) +import Data.Foldable ( toList ) import Data.Functor.Identity ( Identity(..) ) +import Data.List.NonEmpty ( NonEmpty(..) ) import Data.Void ( Void, absurd ) import Control.Monad ( forM_ ) import Control.Monad.Trans.State.Strict @@ -556,6 +558,9 @@ instance HasLoc a => HasLoc [a] where loc [] = noSrcSpan loc xs = foldl1' combineSrcSpans $ map loc xs +instance HasLoc a => HasLoc (DataDefnCons a) where + loc = loc . toList + instance (HasLoc a, HiePass p) => HasLoc (FamEqn (GhcPass p) a) where loc (FamEqn _ a outer_bndrs b _ c) = case outer_bndrs of HsOuterImplicit{} -> @@ -589,6 +594,12 @@ instance ToHie Void where instance (ToHie a) => ToHie [a] where toHie = concatMapM toHie +instance (ToHie a) => ToHie (NonEmpty a) where + toHie = concatMapM toHie + +instance (ToHie a) => ToHie (DataDefnCons a) where + toHie = concatMapM toHie + instance (ToHie a) => ToHie (Bag a) where toHie = toHie . bagToList @@ -1474,8 +1485,8 @@ instance ToHie (LocatedA (TyClDecl GhcRn)) where quant_scope = mkLScopeA $ fromMaybe (noLocA []) $ dd_ctxt defn rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc sig_sc = maybe NoScope mkLScopeA $ dd_kindSig defn - con_sc = foldr combineScopes NoScope $ map mkLScopeA $ dd_cons defn - deriv_sc = foldr combineScopes NoScope $ map mkLScopeA $ dd_derivs defn + con_sc = foldr combineScopes NoScope $ mkLScopeA <$> dd_cons defn + deriv_sc = foldr combineScopes NoScope $ mkLScopeA <$> dd_derivs defn ClassDecl { tcdCtxt = context , tcdLName = name , tcdTyVars = vars @@ -1568,7 +1579,7 @@ instance ToHie (LocatedAn NoEpAnns (InjectivityAnn GhcRn)) where ] instance ToHie (HsDataDefn GhcRn) where - toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM + toHie (HsDataDefn _ ctx _ mkind cons derivs) = concatM [ toHie ctx , toHie mkind , toHie cons @@ -1611,7 +1622,7 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where ConDeclGADT { con_names = names, con_bndrs = L outer_bndrs_loc outer_bndrs , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ , con_doc = doc} -> - [ toHie $ map (C (Decl ConDec $ getRealSpanA span)) names + [ toHie $ C (Decl ConDec $ getRealSpanA span) <$> names , case outer_bndrs of HsOuterImplicit{hso_ximplicit = imp_vars} -> bindingsOnly $ map (C $ TyVarBind (mkScopeA outer_bndrs_loc) resScope) diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 4b367b2da9..e530750745 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -12,6 +12,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE LambdaCase #-} -- | This module provides the generated Happy parser for Haskell. It exports -- a number of parsers which may be used in any library that uses the GHC API. @@ -1660,7 +1661,7 @@ pattern_synonym_sig :: { LSig GhcPs } : 'pattern' con_list '::' sigtype {% acsA (\cs -> sLL $1 (reLoc $>) $ PatSynSig (EpAnn (glR $1) (AnnSig (mu AnnDcolon $3) [mj AnnPattern $1]) cs) - (unLoc $2) $4) } + (toList $ unLoc $2) $4) } qvarcon :: { LocatedN RdrName } : qvar { $1 } @@ -3544,10 +3545,9 @@ con :: { LocatedN RdrName } (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) } | sysdcon { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) } -con_list :: { Located [LocatedN RdrName] } -con_list : con { sL1N $1 [$1] } - | con ',' con_list {% do { h <- addTrailingCommaN $1 (gl $2) - ; return (sLL (reLocN $1) $> (h : unLoc $3)) }} +con_list :: { Located (NonEmpty (LocatedN RdrName)) } +con_list : con { sL1N $1 (pure $1) } + | con ',' con_list {% sLL (reLocN $1) $> . (:| toList (unLoc $3)) <\$> addTrailingCommaN $1 (gl $2) } qcon_list :: { Located [LocatedN RdrName] } qcon_list : qcon { sL1N $1 [$1] } diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 1a368b0fac..b515d89541 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -503,6 +503,12 @@ instance Diagnostic PsMessage where ] PsErrInvalidCApiImport {} -> mkSimpleDecorated $ vcat [ text "Wrapper stubs can't be used with CApiFFI."] + PsErrMultipleConForNewtype tycon n -> mkSimpleDecorated $ vcat + [ sep + [ text "A newtype must have exactly one constructor," + , nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ] + , text "In the newtype declaration for" <+> quotes (ppr tycon) ] + diagnosticReason = \case PsUnknownMessage m -> diagnosticReason m PsHeaderMessage m -> psHeaderMessageReason m @@ -619,6 +625,7 @@ instance Diagnostic PsMessage where PsErrParseRightOpSectionInPat{} -> ErrorWithoutFlag PsErrIllegalGadtRecordMultiplicity{} -> ErrorWithoutFlag PsErrInvalidCApiImport {} -> ErrorWithoutFlag + PsErrMultipleConForNewtype {} -> ErrorWithoutFlag diagnosticHints = \case PsUnknownMessage m -> diagnosticHints m @@ -788,6 +795,7 @@ instance Diagnostic PsMessage where PsErrInvalidPackageName{} -> noHints PsErrIllegalGadtRecordMultiplicity{} -> noHints PsErrInvalidCApiImport {} -> noHints + PsErrMultipleConForNewtype {} -> noHints diagnosticCode = constructorCode diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs index aac26d5532..1b16911700 100644 --- a/compiler/GHC/Parser/Errors/Types.hs +++ b/compiler/GHC/Parser/Errors/Types.hs @@ -463,6 +463,8 @@ data PsMessage | PsErrInvalidCApiImport + | PsErrMultipleConForNewtype !RdrName !Int + deriving Generic -- | Extra details about a parse error, which helps diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 19dac05130..e0bf363f4b 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -230,23 +230,23 @@ mkTyData loc' new_or_data cType (L _ (mcxt, tycl_hdr)) ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams ; cs <- getCommentsFor (locA loc) -- Get any remaining comments ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs - ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + ; data_cons <- checkNewOrData (locA loc) (unLoc tc) new_or_data data_cons + ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv ; return (L loc (DataDecl { tcdDExt = anns', tcdLName = tc, tcdTyVars = tyvars, tcdFixity = fixity, tcdDataDefn = defn })) } -mkDataDefn :: NewOrData - -> Maybe (LocatedP CType) +mkDataDefn :: Maybe (LocatedP CType) -> Maybe (LHsContext GhcPs) -> Maybe (LHsKind GhcPs) - -> [LConDecl GhcPs] + -> DataDefnCons (LConDecl GhcPs) -> HsDeriving GhcPs -> P (HsDataDefn GhcPs) -mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv +mkDataDefn cType mcxt ksig data_cons maybe_deriv = do { checkDatatypeContext mcxt ; return (HsDataDefn { dd_ext = noExtField - , dd_ND = new_or_data, dd_cType = cType + , dd_cType = cType , dd_ctxt = mcxt , dd_cons = data_cons , dd_kindSig = ksig @@ -327,7 +327,8 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan ; let fam_eqn_ans = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments - ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + ; data_cons <- checkNewOrData loc (unLoc tc) new_or_data data_cons + ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv ; return (L (noAnnSrcSpan loc) (DataFamInstD noExtField (DataFamInstDecl (FamEqn { feqn_ext = fam_eqn_ans , feqn_tycon = tc @@ -752,7 +753,7 @@ mkConDeclH98 ann name mb_forall mb_cxt args -- records whether this is a prefix or record GADT constructor. See -- Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details. mkGadtDecl :: SrcSpan - -> [LocatedN RdrName] + -> NonEmpty (LocatedN RdrName) -> LHsUniToken "::" "∷" GhcPs -> LHsSigType GhcPs -> P (LConDecl GhcPs) @@ -2621,6 +2622,12 @@ mkOpaquePragma src , inl_rule = FunLike } +checkNewOrData :: SrcSpan -> RdrName -> NewOrData -> [a] -> P (DataDefnCons a) +checkNewOrData span name = curry $ \ case + (NewType, [a]) -> pure $ NewTypeCon a + (DataType, as) -> pure $ DataTypeCons as + (NewType, as) -> addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrMultipleConForNewtype name (length as) + ----------------------------------------------------------------------------- -- utilities for foreign declarations diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index 8b57a72d52..2194739373 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -48,7 +48,7 @@ Alternative approaches that did not work properly: -} module GHC.Parser.PostProcess.Haddock (addHaddockToModule) where -import GHC.Prelude hiding (mod) +import GHC.Prelude hiding (head, mod) import GHC.Hs @@ -60,6 +60,7 @@ import Data.Semigroup import Data.Foldable import Data.Traversable import Data.Maybe +import Data.List.NonEmpty (head) import Control.Monad import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader @@ -584,7 +585,7 @@ instance HasHaddock (HsDataDefn GhcPs) where -- = MkT1 Int Bool -- ^ Comment on MkT1 -- | MkT2 Char Int -- ^ Comment on MkT2 -- - dd_cons' <- addHaddock (dd_cons defn) + dd_cons' <- traverse addHaddock (dd_cons defn) -- Process the deriving clauses: -- diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 6e196d2b60..7e2c4a0388 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -16,7 +16,7 @@ module GHC.Rename.Module ( rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt ) where -import GHC.Prelude +import GHC.Prelude hiding ( head ) import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr ) import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls ) @@ -72,9 +72,10 @@ import qualified GHC.LanguageExtensions as LangExt import Control.Monad import Control.Arrow ( first ) +import Data.Foldable ( toList ) import Data.List ( mapAccumL ) import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty ( NonEmpty(..) ) +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 ) @@ -1819,11 +1820,11 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdFixity = fixity, - tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data - , dd_kindSig = kind_sig} }) + tcdDataDefn = defn@HsDataDefn{ dd_cons = cons, dd_kindSig = kind_sig} }) = do { tycon' <- lookupLocatedTopConstructorRnN tycon ; let kvs = extractDataDefnKindVars defn doc = TyDataCtx tycon + new_or_data = dataDefnConsNewOrData cons ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs) ; bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' no_rhs_kvs -> do { (defn', fvs) <- rnDataDefn doc defn @@ -1940,8 +1941,7 @@ rnTySyn doc rhs = rnLHsType doc rhs rnDataDefn :: HsDocContext -> HsDataDefn GhcPs -> RnM (HsDataDefn GhcRn, FreeVars) -rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = context, dd_cons = condecls +rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = condecls , dd_kindSig = m_sig, dd_derivs = derivs }) = do { -- DatatypeContexts (i.e., stupid contexts) can't be combined with -- GADT syntax. See Note [The stupid context] in GHC.Core.DataCon. @@ -1966,17 +1966,14 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV` con_fvs `plusFV` sig_fvs - ; return ( HsDataDefn { dd_ext = noExtField - , dd_ND = new_or_data, dd_cType = cType + ; return ( HsDataDefn { dd_ext = noExtField, dd_cType = cType , dd_ctxt = context', dd_kindSig = m_sig' , dd_cons = condecls' , dd_derivs = derivs' } , all_fvs ) } where - h98_style = case condecls of -- Note [Stupid theta] - (L _ (ConDeclGADT {})) : _ -> False - _ -> True + h98_style = not $ anyLConIsGadt condecls -- Note [Stupid theta] rn_derivs ds = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies @@ -2312,7 +2309,7 @@ are no data constructors we allow h98_style = True ***************************************************** -} ----------------- -rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars) +rnConDecls :: DataDefnCons (LConDecl GhcPs) -> RnM (DataDefnCons (LConDecl GhcRn), FreeVars) rnConDecls = mapFvRn (wrapLocFstMA rnConDecl) rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) @@ -2370,7 +2367,7 @@ rnConDecl (ConDeclGADT { con_names = names extractConDeclGADTDetailsTyVars args $ extractHsTysRdrTyVars [res_ty] [] - ; let ctxt = ConDeclCtx new_names + ; let ctxt = ConDeclCtx (toList new_names) ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' -> do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 8f47d2215e..e4f11fa3fd 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -96,6 +96,7 @@ import Data.Ord ( comparing ) import Data.List ( partition, (\\), find, sortBy, groupBy, sortOn ) import Data.Function ( on ) import qualified Data.Set as S +import Data.Foldable ( toList ) import System.FilePath (()) import System.IO @@ -982,7 +983,7 @@ getLocalNonValBinders fixity_env , con_g_args = RecConGADT flds _ })) = [ ( find_con_name rdr , concatMap find_con_decl_flds (unLoc flds)) - | L _ rdr <- rdrs ] + | L _ rdr <- toList rdrs ] find_con_flds _ = [] diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 78e3285a24..82f9623067 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -37,7 +37,7 @@ module GHC.Rename.Utils ( where -import GHC.Prelude +import GHC.Prelude hiding (unzip) import GHC.Core.Type import GHC.Hs @@ -68,6 +68,7 @@ import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) import qualified Data.List.NonEmpty as NE import qualified GHC.LanguageExtensions as LangExt import GHC.Data.Bag +import qualified Data.List as List {- ********************************************************* @@ -327,10 +328,17 @@ addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars) addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside ; return (res, fvs1 `plusFV` fvs2) } -mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) -mapFvRn f xs = do stuff <- mapM f xs - case unzip stuff of - (ys, fvs_s) -> return (ys, plusFVs fvs_s) +mapFvRn :: Traversable f => (a -> RnM (b, FreeVars)) -> f a -> RnM (f b, FreeVars) +mapFvRn f xs = do + stuff <- mapM f xs + case unzip stuff of + (ys, fvs_s) -> return (ys, foldl' (flip plusFV) emptyFVs fvs_s) +{-# SPECIALIZE mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) #-} + +unzip :: Functor f => f (a, b) -> (f a, f b) +unzip = \ xs -> (fmap fst xs, fmap snd xs) +{-# NOINLINE [1] unzip #-} +{-# RULES "unzip/List" unzip = List.unzip #-} mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars) mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs) diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 67697eb55e..d0eb6337ef 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -102,9 +102,11 @@ import GHC.Utils.Misc import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import Control.Monad +import Data.Foldable ( toList, traverse_ ) import Data.Functor.Identity import Data.List ( partition) import Data.List.NonEmpty ( NonEmpty(..) ) +import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import Data.Tuple( swap ) @@ -1286,7 +1288,7 @@ mk_prom_err_env (DataDecl { tcdLName = L _ name = unitNameEnv name (APromotionErr TyConPE) `plusNameEnv` mkNameEnv [ (con, APromotionErr RecDataConPE) - | L _ con' <- cons + | L _ con' <- toList cons , L _ con <- getConNames con' ] mk_prom_err_env decl @@ -1355,14 +1357,13 @@ getInitialKind strategy getInitialKind strategy (DataDecl { tcdLName = L _ name , tcdTyVars = ktvs - , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig - , dd_ND = new_or_data } }) - = do { let flav = newOrDataToFlavour new_or_data + , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig, dd_cons = cons } }) + = do { let flav = newOrDataToFlavour (dataDefnConsNewOrData cons) ctxt = DataKindCtxt name ; tc <- kcDeclHeader strategy name flav ktvs $ case m_sig of Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig - Nothing -> return $ dataDeclDefaultResultKind strategy new_or_data + Nothing -> return $ dataDeclDefaultResultKind strategy (dataDefnConsNewOrData cons) ; return [tc] } getInitialKind InitialKindInfer (FamDecl { tcdFam = decl }) @@ -1570,8 +1571,7 @@ kcTyClDecl :: TyClDecl GhcRn -> MonoTcTyCon -> TcM () -- - In this function, those TcTyVars are unified with other kind variables during -- kind inference (see [How TcTyCons work]) -kcTyClDecl (DataDecl { tcdLName = (L _ _name), tcdDataDefn = defn }) tycon - | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_ND = new_or_data } <- defn +kcTyClDecl (DataDecl { tcdLName = (L _ _name), tcdDataDefn = HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } }) tycon = tcExtendNameTyVarEnv (tcTyConScopedTyVars tycon) $ -- NB: binding these tyvars isn't necessary for GADTs, but it does no -- harm. For GADTs, each data con brings its own tyvars into scope, @@ -1579,7 +1579,7 @@ kcTyClDecl (DataDecl { tcdLName = (L _ _name), tcdDataDefn = defn }) tycon -- (conceivably) shadowed. do { traceTc "kcTyClDecl" (ppr tycon $$ ppr (tyConTyVars tycon) $$ ppr (tyConResKind tycon)) ; _ <- tcHsContext ctxt - ; kcConDecls new_or_data (tyConResKind tycon) cons + ; kcConDecls (dataDefnConsNewOrData cons) (tyConResKind tycon) cons } kcTyClDecl (SynDecl { tcdLName = L _ _name, tcdRhs = rhs }) tycon @@ -1634,14 +1634,14 @@ kcConGADTArgs new_or_data res_kind con_args = case con_args of RecConGADT (L _ flds) _ -> kcConArgTys new_or_data res_kind $ map (hsLinear . cd_fld_type . unLoc) flds -kcConDecls :: NewOrData +kcConDecls :: Foldable f + => NewOrData -> TcKind -- The result kind signature -- Used only in H98 case - -> [LConDecl GhcRn] -- The data constructors + -> f (LConDecl GhcRn) -- The data constructors -> TcM () -- See Note [kcConDecls: kind-checking data type decls] -kcConDecls new_or_data tc_res_kind cons - = mapM_ (wrapLocMA_ (kcConDecl new_or_data tc_res_kind)) cons +kcConDecls new_or_data tc_res_kind = traverse_ (wrapLocMA_ (kcConDecl new_or_data tc_res_kind)) -- Kind check a data constructor. In additional to the data constructor, -- we also need to know about whether or not its corresponding type was @@ -1658,7 +1658,7 @@ kcConDecl :: NewOrData kcConDecl new_or_data tc_res_kind (ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs , con_mb_cxt = ex_ctxt, con_args = args }) - = addErrCtxt (dataConCtxt [name]) $ + = addErrCtxt (dataConCtxt (NE.singleton name)) $ discardResult $ bindExplicitTKBndrs_Tv ex_tvs $ do { _ <- tcHsContext ex_ctxt @@ -2873,7 +2873,7 @@ tcDataDefn :: SDoc -> RolesInfo -> Name -> HsDataDefn GhcRn -> TcM (TyCon, [DerivInfo]) -- NB: not used for newtype/data instances (whether associated or not) tcDataDefn err_ctxt roles_info tc_name - (HsDataDefn { dd_ND = new_or_data, dd_cType = cType + (HsDataDefn { dd_cType = cType , dd_ctxt = ctxt , dd_kindSig = mb_ksig -- Already in tc's kind -- via inferInitialKinds @@ -2885,12 +2885,12 @@ tcDataDefn err_ctxt roles_info tc_name -- - for H98 constructors only, the ConDecl -- But it does no harm to bring them into scope -- over GADT ConDecls as well; and it's awkward not to - do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons + do { gadt_syntax <- dataDeclChecks tc_name ctxt cons ; tcg_env <- getGblEnv ; let hsc_src = tcg_src tcg_env ; unless (mk_permissive_kind hsc_src cons) $ - checkDataKindSig (DataDeclSort new_or_data) res_kind + checkDataKindSig (DataDeclSort (dataDefnConsNewOrData cons)) res_kind ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info tc_bndrs $ tcHsContext ctxt @@ -2918,8 +2918,7 @@ tcDataDefn err_ctxt roles_info tc_name ; res_kind <- zonkTcTypeToTypeX ze res_kind ; tycon <- fixM $ \ rec_tycon -> do - { data_cons <- tcConDecls new_or_data DDataType rec_tycon - tc_bndrs res_kind cons + { data_cons <- tcConDecls DDataType rec_tycon tc_bndrs res_kind cons ; tc_rhs <- mk_tc_rhs hsc_src rec_tycon data_cons ; tc_rep_nm <- newTyConRepName tc_name @@ -2943,7 +2942,7 @@ tcDataDefn err_ctxt roles_info tc_name ; return (tycon, [deriv_info]) } where skol_info = TyConSkol flav tc_name - flav = newOrDataToFlavour new_or_data + flav = newOrDataToFlavour (dataDefnConsNewOrData cons) -- Abstract data types in hsig files can have arbitrary kinds, -- because they may be implemented by type synonyms @@ -2953,23 +2952,21 @@ tcDataDefn err_ctxt roles_info tc_name -- so one could not have, say, a data family instance in an hsig file that -- has kind `Bool`. Therefore, this check need only occur in the code that -- typechecks data type declarations. - mk_permissive_kind HsigFile [] = True + mk_permissive_kind HsigFile (DataTypeCons []) = True mk_permissive_kind _ _ = False -- In an hs-boot or a signature file, -- a 'data' declaration with no constructors -- indicates a nominally distinct abstract data type. - mk_tc_rhs (isHsBootOrSig -> True) _ [] + mk_tc_rhs (isHsBootOrSig -> True) _ (DataTypeCons []) = return AbstractTyCon - mk_tc_rhs _ tycon data_cons - = case new_or_data of - DataType -> return $ + mk_tc_rhs _ tycon data_cons = case data_cons of + DataTypeCons data_cons -> return $ mkLevPolyDataTyConRhs (isFixedRuntimeRepKind (tyConResKind tycon)) data_cons - NewType -> assert (not (null data_cons)) $ - mkNewTyConRhs tc_name tycon (head data_cons) + NewTypeCon data_con -> mkNewTyConRhs tc_name tycon data_con ------------------------- kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM () @@ -3312,26 +3309,20 @@ that 'a' must have that kind, and to bring 'k' into scope. ************************************************************************ -} -dataDeclChecks :: Name -> NewOrData - -> Maybe (LHsContext GhcRn) -> [LConDecl GhcRn] +dataDeclChecks :: Name + -> Maybe (LHsContext GhcRn) -> DataDefnCons (LConDecl GhcRn) -> TcM Bool -dataDeclChecks tc_name new_or_data mctxt cons +dataDeclChecks tc_name mctxt cons = do { let stupid_theta = fromMaybeContext mctxt -- Check that we don't use GADT syntax in H98 world ; gadtSyntax_ok <- xoptM LangExt.GADTSyntax - ; let gadt_syntax = consUseGadtSyntax cons + ; let gadt_syntax = anyLConIsGadt cons ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name) -- Check that the stupid theta is empty for a GADT-style declaration. -- See Note [The stupid context] in GHC.Core.DataCon. ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name) - -- Check that a newtype has exactly one constructor - -- Do this before checking for empty data decls, so that - -- we don't suggest -XEmptyDataDecls for newtypes - ; checkTc (new_or_data == DataType || isSingleton cons) - (newtypeConError tc_name (length cons)) - -- Check that there's at least one condecl, -- or else we're reading an hs-boot file, or -XEmptyDataDecls ; empty_data_decls <- xoptM LangExt.EmptyDataDecls @@ -3341,12 +3332,6 @@ dataDeclChecks tc_name new_or_data mctxt cons ; return gadt_syntax } ------------------------------------ -consUseGadtSyntax :: [LConDecl GhcRn] -> Bool -consUseGadtSyntax (L _ (ConDeclGADT {}) : _) = True -consUseGadtSyntax _ = False - -- All constructors have same shape - ----------------------------------- data DataDeclInfo = DDataType -- data T a b = T1 a | T2 b @@ -3360,19 +3345,30 @@ mkDDHeaderTy dd_info rep_tycon tc_bndrs mkTyVarTys (binderVars tc_bndrs) DDataInstance header_ty -> header_ty -tcConDecls :: NewOrData - -> DataDeclInfo +-- We use `concatMapDataDefnConsTcM` here, since the following is illegal: +-- @newtype T a where T1, T2 :: a -> T a@ +-- It would be represented as a single 'ConDeclGadt' with multiple names, which is valid for 'data', but not 'newtype'. +-- So when 'tcConDecl' expands the 'ConDecl' per each name it has, if we are type-checking a 'newtype' declaration, we +-- must fail if it returns more than one. +tcConDecls :: DataDeclInfo -> KnotTied TyCon -- Representation TyCon -> [TcTyConBinder] -- Binders of representation TyCon -> TcKind -- Result kind - -> [LConDecl GhcRn] -> TcM [DataCon] -tcConDecls new_or_data dd_info rep_tycon tmpl_bndrs res_kind - = concatMapM $ addLocMA $ - tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind - (mkTyConTagMap rep_tycon) + -> DataDefnCons (LConDecl GhcRn) -> TcM (DataDefnCons DataCon) +tcConDecls dd_info rep_tycon tmpl_bndrs res_kind + = concatMapDataDefnConsTcM (tyConName rep_tycon) $ \ new_or_data -> + addLocMA $ tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind (mkTyConTagMap rep_tycon) -- mkTyConTagMap: it's important that we pay for tag allocation here, -- once per TyCon. See Note [Constructor tag allocation], fixes #14657 +-- 'concatMap' for 'DataDefnCons', but fail if the given function returns multiple values and the argument is a 'NewTypeCon'. +concatMapDataDefnConsTcM :: Name -> (NewOrData -> a -> TcM (NonEmpty b)) -> DataDefnCons a -> TcM (DataDefnCons b) +concatMapDataDefnConsTcM name f = \ case + NewTypeCon a -> f NewType a >>= \ case + b:|[] -> pure (NewTypeCon b) + bs -> failWithTc $ newtypeConError name (length bs) + DataTypeCons as -> DataTypeCons <$> concatMapM (fmap toList . f DataType) as + tcConDecl :: NewOrData -> DataDeclInfo -> KnotTied TyCon -- Representation tycon. Knot-tied! @@ -3380,14 +3376,14 @@ tcConDecl :: NewOrData -> TcKind -- Result kind -> NameEnv ConTag -> ConDecl GhcRn - -> TcM [DataCon] + -> TcM (NonEmpty DataCon) tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map (ConDeclH98 { con_name = lname@(L _ name) , con_ex_tvs = explicit_tkv_nms , con_mb_cxt = hs_ctxt , con_args = hs_args }) - = addErrCtxt (dataConCtxt [lname]) $ + = addErrCtxt (dataConCtxt (NE.singleton lname)) $ do { -- NB: the tyvars from the declaration header are in scope -- Get hold of the existential type variables @@ -3475,7 +3471,7 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map -- constructor type signature into the data constructor; -- that way checkValidDataCon can complain if it's wrong. - ; return [dc] } + ; return (NE.singleton dc) } tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map -- NB: don't use res_kind here, as it's ill-scoped. Instead, @@ -3486,7 +3482,7 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map , con_res_ty = hs_res_ty }) = addErrCtxt (dataConCtxt names) $ do { traceTc "tcConDecl 1 gadt" (ppr names) - ; let (L _ name : _) = names + ; let L _ name :| _ = names ; skol_info <- mkSkolemInfo (DataConSkol name) ; (tclvl, wanted, (outer_bndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts))) <- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $ @@ -4345,7 +4341,7 @@ checkFieldCompat fld con1 con2 res1 res2 fty1 fty2 checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM () checkValidDataCon dflags existential_ok tc con = setSrcSpan con_loc $ - addErrCtxt (dataConCtxt [L (noAnnSrcSpan con_loc) con_name]) $ + addErrCtxt (dataConCtxt (NE.singleton (L (noAnnSrcSpan con_loc) con_name))) $ do { let tc_tvs = tyConTyVars tc res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs) arg_tys = dataConOrigArgTys con @@ -5239,13 +5235,13 @@ fieldTypeMisMatch field_name con1 con2 sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, text "give different types for field", quotes (ppr field_name)] -dataConCtxt :: [LocatedN Name] -> SDoc -dataConCtxt cons = text "In the definition of data constructor" <> plural cons - <+> ppr_cons cons +dataConCtxt :: NonEmpty (LocatedN Name) -> SDoc +dataConCtxt cons = text "In the definition of data constructor" <> plural (toList cons) + <+> ppr_cons (toList cons) -dataConResCtxt :: [LocatedN Name] -> SDoc -dataConResCtxt cons = text "In the result type of data constructor" <> plural cons - <+> ppr_cons cons +dataConResCtxt :: NonEmpty (LocatedN Name) -> SDoc +dataConResCtxt cons = text "In the result type of data constructor" <> plural (toList cons) + <+> ppr_cons (toList cons) ppr_cons :: [LocatedN Name] -> SDoc ppr_cons [con] = quotes (ppr con) diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 879280d203..32d710dec7 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -79,7 +79,6 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Data.BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) @@ -674,8 +673,7 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env , feqn_pats = hs_pats , feqn_tycon = lfam_name@(L _ fam_name) , feqn_fixity = fixity - , feqn_rhs = HsDataDefn { dd_ND = new_or_data - , dd_cType = cType + , feqn_rhs = HsDataDefn { dd_cType = cType , dd_ctxt = hs_ctxt , dd_cons = hs_cons , dd_kindSig = m_ksig @@ -688,10 +686,11 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env -- Check that the family declaration is for the right kind ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons + ; gadt_syntax <- dataDeclChecks fam_name hs_ctxt hs_cons -- Do /not/ check that the number of patterns = tyConArity fam_tc -- See [Arity of data families] in GHC.Core.FamInstEnv ; skol_info <- mkSkolemInfo FamInstSkol + ; let new_or_data = dataDefnConsNewOrData hs_cons ; (qtvs, pats, tc_res_kind, stupid_theta) <- tcDataFamInstHeader mb_clsinfo skol_info fam_tc outer_bndrs fixity hs_ctxt hs_pats m_ksig new_or_data @@ -767,19 +766,17 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env do { data_cons <- tcExtendTyVarEnv (binderVars tc_ty_binders) $ -- For H98 decls, the tyvars scope -- over the data constructors - tcConDecls new_or_data (DDataInstance orig_res_ty) - rec_rep_tc tc_ty_binders tc_res_kind - hs_cons + tcConDecls (DDataInstance orig_res_ty) rec_rep_tc tc_ty_binders tc_res_kind + hs_cons ; rep_tc_name <- newFamInstTyConName lfam_name pats ; axiom_name <- newFamInstAxiomName lfam_name [pats] - ; tc_rhs <- case new_or_data of - DataType -> return $ + ; tc_rhs <- case data_cons of + DataTypeCons data_cons -> return $ mkLevPolyDataTyConRhs (isFixedRuntimeRepKind res_kind) data_cons - NewType -> assert (not (null data_cons)) $ - mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons) + NewTypeCon data_con -> mkNewTyConRhs rep_tc_name rec_rep_tc data_con ; let ax_rhs = mkTyConApp rep_tc (mkTyVarTys zonked_post_eta_qtvs) axiom = mkSingleCoAxiom Representational axiom_name @@ -893,7 +890,6 @@ tcDataFamInstHeader -> NewOrData -> TcM ([TcTyVar], [TcType], TcKind, TcThetaType) -- All skolem TcTyVars, all zonked so it's clear what the free vars are - -- The "header" of a data family instance is the part other than -- the data constructors themselves -- e.g. data instance D [a] :: * -> * where ... diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 5ba99fe7ac..f7ba81db6b 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -60,6 +60,7 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import qualified Data.ByteString as BS import Control.Monad( unless, ap ) import Control.Applicative( (<|>) ) +import Data.List.NonEmpty( NonEmpty (..), nonEmpty ) import Data.Maybe( catMaybes, isNothing ) import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH.Syntax as TH @@ -290,10 +291,10 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs) ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField - , dd_ND = DataType, dd_cType = Nothing + , dd_cType = Nothing , dd_ctxt = mkHsContextMaybe ctxt' , dd_kindSig = ksig' - , dd_cons = cons', dd_derivs = derivs' } + , dd_cons = DataTypeCons cons', dd_derivs = derivs' } ; returnJustLA $ TyClD noExtField $ DataDecl { tcdDExt = noAnn , tcdLName = tc', tcdTyVars = tvs' @@ -306,10 +307,10 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs) ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField - , dd_ND = NewType, dd_cType = Nothing + , dd_cType = Nothing , dd_ctxt = mkHsContextMaybe ctxt' , dd_kindSig = ksig' - , dd_cons = [con'] + , dd_cons = NewTypeCon con' , dd_derivs = derivs' } ; returnJustLA $ TyClD noExtField $ DataDecl { tcdDExt = noAnn @@ -377,10 +378,10 @@ cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs) ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField - , dd_ND = DataType, dd_cType = Nothing + , dd_cType = Nothing , dd_ctxt = mkHsContextMaybe ctxt' , dd_kindSig = ksig' - , dd_cons = cons', dd_derivs = derivs' } + , dd_cons = DataTypeCons cons', dd_derivs = derivs' } ; returnJustLA $ InstD noExtField $ DataFamInstD { dfid_ext = noExtField @@ -398,10 +399,10 @@ cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs) ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ext = noExtField - , dd_ND = NewType, dd_cType = Nothing + , dd_cType = Nothing , dd_ctxt = mkHsContextMaybe ctxt' , dd_kindSig = ksig' - , dd_cons = [con'], dd_derivs = derivs' } + , dd_cons = NewTypeCon con', dd_derivs = derivs' } ; returnJustLA $ InstD noExtField $ DataFamInstD { dfid_ext = noExtField , dfid_inst = DataFamInstDecl { dfid_eqn = @@ -679,26 +680,24 @@ cvtConstr (ForallC tvs ctxt con) where all_tvs = tvs' ++ ex_tvs -cvtConstr (GadtC [] _strtys _ty) - = failWith (text "GadtC must have at least one constructor name") - -cvtConstr (GadtC c strtys ty) - = do { c' <- mapM cNameN c +cvtConstr (GadtC c strtys ty) = case nonEmpty c of + Nothing -> failWith (text "GadtC must have at least one constructor name") + Just c -> do + { c' <- mapM cNameN c ; args <- mapM cvt_arg strtys ; ty' <- cvtType ty ; mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'} -cvtConstr (RecGadtC [] _varstrtys _ty) - = failWith (text "RecGadtC must have at least one constructor name") - -cvtConstr (RecGadtC c varstrtys ty) - = do { c' <- mapM cNameN c +cvtConstr (RecGadtC c varstrtys ty) = case nonEmpty c of + Nothing -> failWith (text "RecGadtC must have at least one constructor name") + Just c -> do + { c' <- mapM cNameN c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys ; lrec_flds <- returnLA rec_flds ; mk_gadt_decl c' (RecConGADT lrec_flds noHsUniTok) ty' } -mk_gadt_decl :: [LocatedN RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs +mk_gadt_decl :: NonEmpty (LocatedN RdrName) -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs -> CvtM (LConDecl GhcPs) mk_gadt_decl names args res_ty = do bndrs <- returnLA mkHsOuterImplicit diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs index cb24cda08a..639863c630 100644 --- a/compiler/GHC/Types/Error/Codes.hs +++ b/compiler/GHC/Types/Error/Codes.hs @@ -136,7 +136,6 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "DsRuleLhsTooComplicated" = 69441 GhcDiagnosticCode "DsRuleIgnoredDueToConstructor" = 00828 GhcDiagnosticCode "DsRuleBindersNotBound" = 40548 - GhcDiagnosticCode "DsMultipleConForNewtype" = 05380 GhcDiagnosticCode "DsLazyPatCantBindVarsOfUnliftedType" = 17879 GhcDiagnosticCode "DsNotYetHandledByTH" = 65904 GhcDiagnosticCode "DsAggregatedViewExpressions" = 19551 @@ -267,6 +266,7 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "PsErrParseRightOpSectionInPat" = 72516 GhcDiagnosticCode "PsErrIllegalGadtRecordMultiplicity" = 37475 GhcDiagnosticCode "PsErrInvalidCApiImport" = 72744 + GhcDiagnosticCode "PsErrMultipleConForNewtype" = 05380 -- Driver diagnostic codes GhcDiagnosticCode "DriverMissingHomeModules" = 32850 diff --git a/compiler/GHC/Utils/Monad.hs b/compiler/GHC/Utils/Monad.hs index b0605b96b0..5366d12dca 100644 --- a/compiler/GHC/Utils/Monad.hs +++ b/compiler/GHC/Utils/Monad.hs @@ -161,8 +161,9 @@ mapSndM :: (Applicative m, Traversable f) => (b -> m c) -> f (a,b) -> m (f (a,c) mapSndM = traverse . traverse -- | Monadic version of concatMap -concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM :: (Monad m, Traversable f) => (a -> m [b]) -> f a -> m [b] concatMapM f xs = liftM concat (mapM f xs) +{-# SPECIALIZE concatMapM :: (Monad m) => (a -> m [b]) -> [a] -> m [b] #-} -- | Applicative version of mapMaybe mapMaybeM :: Applicative m => (a -> m (Maybe b)) -> [a] -> m [b] -- cgit v1.2.1