diff options
69 files changed, 575 insertions, 35 deletions
diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs index d8b26558aa..e50290a5f8 100644 --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -57,7 +57,8 @@ module GHC.Core.DataCon ( isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isBoxedTupleDataCon, isUnboxedTupleDataCon, isUnboxedSumDataCon, - isVanillaDataCon, isNewDataCon, classDataCon, dataConCannotMatch, + isVanillaDataCon, isNewDataCon, isTypeDataCon, + classDataCon, dataConCannotMatch, dataConUserTyVarsArePermuted, isBanged, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked, specialPromotedDc, @@ -1634,6 +1635,11 @@ isVanillaDataCon dc = dcVanilla dc isNewDataCon :: DataCon -> Bool isNewDataCon dc = isNewTyCon (dataConTyCon dc) +-- | Is this data constructor in a "type data" declaration? +-- See Note [Type data declarations] in GHC.Rename.Module. +isTypeDataCon :: DataCon -> Bool +isTypeDataCon dc = isTcClsNameSpace (nameNameSpace (getName dc)) + -- | Should this DataCon be allowed in a type even without -XDataKinds? -- Currently, only Lifted & Unlifted specialPromotedDc :: DataCon -> Bool diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 38bb6598b4..017b8bce20 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -3759,6 +3759,7 @@ xFlagsDeps = [ flagSpec "TransformListComp" LangExt.TransformListComp, flagSpec "TupleSections" LangExt.TupleSections, flagSpec "TypeApplications" LangExt.TypeApplications, + flagSpec "TypeData" LangExt.TypeData, depFlagSpec' "TypeInType" LangExt.TypeInType (deprecatedForExtensions ["DataKinds", "PolyKinds"]), flagSpec "TypeFamilies" LangExt.TypeFamilies, diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index 1db54bfc4b..c4a79f25a7 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -401,7 +401,7 @@ countTyClDecls decls count isNewTy decls, -- ...instances count isFamilyDecl decls) where - isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_cons = DataTypeCons _ } } = True + isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_cons = DataTypeCons _ _ } } = True isDataTy _ = False isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_cons = NewTypeCon _ } } = True @@ -698,8 +698,11 @@ ppDataDefnHeader pp_hdr HsDataDefn , dd_cType = mb_ct , dd_kindSig = mb_sig , dd_cons = condecls } - = ppr (dataDefnConsNewOrData condecls) <+> pp_ct <+> pp_hdr context <+> pp_sig + = pp_type <+> ppr (dataDefnConsNewOrData condecls) <+> pp_ct <+> pp_hdr context <+> pp_sig where + pp_type + | isTypeDataDefnCons condecls = text "type" + | otherwise = empty pp_ct = case mb_ct of Nothing -> empty Just ct -> ppr ct diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index e6f8ce4c51..c707a29368 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -527,7 +527,7 @@ repDataDefn tc opts ; ksig' <- repMaybeLTy ksig ; repNewtype cxt1 tc opts ksig' con' derivs1 } - DataTypeCons cons -> do { ksig' <- repMaybeLTy ksig + DataTypeCons _ cons -> do { ksig' <- repMaybeLTy ksig ; consL <- mapM repC cons ; cons1 <- coreListM conTyConName consL ; repData cxt1 tc opts ksig' cons1 diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index e530750745..fd1cd5d3ae 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -1271,22 +1271,22 @@ ty_decl :: { LTyClDecl GhcPs } ++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) } -- ordinary data type or newtype declaration - | data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings - {% mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3 + | type_data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings + {% mkTyData (comb4 $1 $3 $4 $5) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3 Nothing (reverse (snd $ unLoc $4)) (fmap reverse $5) - ((fst $ unLoc $1):(fst $ unLoc $4)) } + ((fstOf3 $ unLoc $1):(fst $ unLoc $4)) } -- We need the location on tycl_hdr in case -- constrs and deriving are both empty -- ordinary GADT declaration - | data_or_newtype capi_ctype tycl_hdr opt_kind_sig + | type_data_or_newtype capi_ctype tycl_hdr opt_kind_sig gadt_constrlist maybe_derivings - {% mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3 + {% mkTyData (comb4 $1 $3 $5 $6) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3 (snd $ unLoc $4) (snd $ unLoc $5) (fmap reverse $6) - ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) } + ((fstOf3 $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) } -- We need the location on tycl_hdr in case -- constrs and deriving are both empty @@ -1510,6 +1510,11 @@ at_decl_inst :: { LInstDecl GhcPs } (fmap reverse $7) ((fst $ unLoc $1):$2++(fst $ unLoc $5)++(fst $ unLoc $6)) } +type_data_or_newtype :: { Located (AddEpAnn, Bool, NewOrData) } + : 'data' { sL1 $1 (mj AnnData $1,False,DataType) } + | 'newtype' { sL1 $1 (mj AnnNewtype $1,False,NewType) } + | 'type' 'data' { sL1 $1 (mj AnnData $1,True ,DataType) } + data_or_newtype :: { Located (AddEpAnn, NewOrData) } : 'data' { sL1 $1 (mj AnnData $1,DataType) } | 'newtype' { sL1 $1 (mj AnnNewtype $1,NewType) } diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 928e7ce4aa..ced580d743 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -215,6 +215,7 @@ mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo annsIn , tcdDocs = docs })) } mkTyData :: SrcSpan + -> Bool -> NewOrData -> Maybe (LocatedP CType) -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) @@ -223,14 +224,14 @@ mkTyData :: SrcSpan -> Located (HsDeriving GhcPs) -> [AddEpAnn] -> P (LTyClDecl GhcPs) -mkTyData loc' new_or_data cType (L _ (mcxt, tycl_hdr)) +mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons (L _ maybe_deriv) annsIn = do { let loc = noAnnSrcSpan loc' ; (tc, tparams, fixity, ann) <- checkTyClHdr False 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 - ; data_cons <- checkNewOrData (locA loc) (unLoc tc) new_or_data data_cons + ; data_cons <- checkNewOrData (locA loc) (unLoc tc) is_type_data new_or_data data_cons ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv ; return (L loc (DataDecl { tcdDExt = anns', tcdLName = tc, tcdTyVars = tyvars, @@ -252,7 +253,6 @@ mkDataDefn cType mcxt ksig data_cons maybe_deriv , dd_kindSig = ksig , dd_derivs = maybe_deriv }) } - mkTySynonym :: SrcSpan -> LHsType GhcPs -- LHS -> LHsType GhcPs -- RHS @@ -327,7 +327,7 @@ 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 - ; data_cons <- checkNewOrData loc (unLoc tc) new_or_data data_cons + ; data_cons <- checkNewOrData loc (unLoc tc) False 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 @@ -2622,11 +2622,27 @@ mkOpaquePragma src , inl_rule = FunLike } -checkNewOrData :: SrcSpan -> RdrName -> NewOrData -> [a] -> P (DataDefnCons a) -checkNewOrData span name = curry $ \ case +checkNewOrData :: SrcSpan -> RdrName -> Bool -> NewOrData -> [LConDecl GhcPs] + -> P (DataDefnCons (LConDecl GhcPs)) +checkNewOrData span name is_type_data = curry $ \ case (NewType, [a]) -> pure $ NewTypeCon a - (DataType, as) -> pure $ DataTypeCons as + (DataType, as) -> pure $ DataTypeCons is_type_data (handle_type_data as) (NewType, as) -> addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrMultipleConForNewtype name (length as) + where + -- In a "type data" declaration, the constructors are in the type/class + -- namespace rather than the data constructor namespace. + -- See Note [Type data declarations] in GHC.Rename.Module. + handle_type_data + | is_type_data = map (fmap promote_constructor) + | otherwise = id + + promote_constructor (dc@ConDeclGADT { con_names = cons }) + = dc { con_names = fmap (fmap promote_name) cons } + promote_constructor (dc@ConDeclH98 { con_name = con }) + = dc { con_name = fmap promote_name con } + promote_constructor dc = dc + + promote_name name = fromMaybe name (promoteRdrName name) ----------------------------------------------------------------------------- -- utilities for foreign declarations diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 7e2c4a0388..6748d60a56 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -69,6 +69,7 @@ import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..) import GHC.Types.Unique.Set import GHC.Data.OrdList import qualified GHC.LanguageExtensions as LangExt +import GHC.Core.DataCon ( isSrcStrict ) import Control.Monad import Control.Arrow ( first ) @@ -1948,6 +1949,10 @@ rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = cond checkTc (h98_style || null (fromMaybeContext context)) (badGadtStupidTheta doc) + -- Check restrictions on "type data" declarations. + -- See Note [Type data declarations]. + ; when (isTypeDataDefnCons condecls) check_type_data + ; (m_sig', sig_fvs) <- case m_sig of Just sig -> first Just <$> rnLHsKind doc sig Nothing -> return (Nothing, emptyFVs) @@ -1982,6 +1987,121 @@ rnDataDefn doc (HsDataDefn { dd_cType = cType, dd_ctxt = context, dd_cons = cond ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds ; return (ds', fvs) } + -- Given a "type data" declaration, check that the TypeData extension + -- is enabled and check restrictions (R1), (R2), (R3) and (R5) + -- on the declaration. See Note [Type data declarations]. + check_type_data + = do { unlessXOptM LangExt.TypeData $ failWith TcRnIllegalTypeData + ; unless (null (fromMaybeContext context)) $ + failWith $ TcRnTypeDataForbids TypeDataForbidsDatatypeContexts + ; mapM_ (addLocMA check_type_data_condecl) condecls + ; unless (null derivs) $ + failWith $ TcRnTypeDataForbids TypeDataForbidsDerivingClauses + } + + -- Check restrictions (R2) and (R3) on a "type data" constructor. + -- See Note [Type data declarations]. + check_type_data_condecl :: ConDecl GhcPs -> RnM () + check_type_data_condecl condecl + = do { + ; when (has_labelled_fields condecl) $ + failWith $ TcRnTypeDataForbids TypeDataForbidsLabelledFields + ; when (has_strictness_flags condecl) $ + failWith $ TcRnTypeDataForbids TypeDataForbidsStrictnessAnnotations + } + + has_labelled_fields (ConDeclGADT { con_g_args = RecConGADT _ _ }) = True + has_labelled_fields (ConDeclH98 { con_args = RecCon rec }) + = not (null (unLoc rec)) + has_labelled_fields _ = False + + has_strictness_flags condecl + = any (is_strict . getBangStrictness . hsScaledThing) (con_args condecl) + + is_strict (HsSrcBang _ _ s) = isSrcStrict s + + con_args (ConDeclGADT { con_g_args = PrefixConGADT args }) = args + con_args (ConDeclH98 { con_args = PrefixCon _ args }) = args + con_args (ConDeclH98 { con_args = InfixCon arg1 arg2 }) = [arg1, arg2] + con_args _ = [] + +{- +Note [Type data declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With the TypeData extension (GHC proposal #106), one can write "type data" +declarations, like + + type data Nat = Zero | Succ Nat + +or equivalently in GADT style: + + type data Nat where + Zero :: Nat + Succ :: Nat -> Nat + +This defines the constructors Zero and Succ in the TcCls namespace +(type constructors and classes) instead of the Data namespace (data +constructors). This contrasts with the DataKinds extension, which allows +constructors defined in the Data namespace to be promoted to the TcCls +namespace at the point of use in a type. + +Type data declarations have the syntax of data declarations, either +ordinary algebraic data types or GADTs, preceded by "type", with the +following restrictions: + +(R1) There are data type contexts (even with the DatatypeContexts extension). + +(R2) There are no labelled fields. Perhaps these could be supported + using type families, but they are omitted for now. + +(R3) There are no strictness flags, because they don't make sense at + the type level. + +(R4) The types of the constructors contain no constraints other than + equality constraints. (This is the same restriction imposed + on constructors to be promoted with the DataKinds extension in + dc_theta_illegal_constraint called from GHC.Tc.Gen.HsType.tcTyVar, + but in that case the restriction is imposed if and when a data + constructor is used in a type, whereas here it is imposed at + the point of definition. See also Note [Constraints in kinds] + in GHC.Core.TyCo.Rep.) + +(R5) There are no deriving clauses. + +The main parts of the implementation are: + +* The Bool argument to DataTypeCons (in Language.Haskell.Syntax.Decls) + distinguishes "type data" declarations from ordinary "data" declarations. + +* This flag is set, and the constructor names placed in the + TcCls namespace, during the initial construction of the AST in + GHC.Parser.PostProcess.checkNewOrData. + +* GHC.Rename.Module.rnDataDefn calls check_type_data on these + declarations, which checks that the TypeData extension is enabled and + checks restrictions (R1), (R2), (R3) and (R5). They could equally + well be checked in the typechecker, but we err on the side of catching + imposters early. + +* GHC.Tc.TyCl.checkValidDataCon checks restriction (R4) on these declarations. + +* When beginning to type check a mutually recursive group of declarations, + the "type data" constructors are added to the type-checker environment + as APromotionErr TyConPE by GHC.Tc.TyCl.mkPromotionErrorEnv, so they + cannot be used within the recursive group. This mirrors the DataKinds + behaviour described at Note [Recursion and promoting data constructors] + in GHC.Tc.TyCl. For example, this is rejected: + + type data T f = K (f (K Int)) + +* After a "type data" declaration has been type-checked, the type-checker + environment entry for each constructor (which can be recognized + by being in the TcCls namespace) is just the promoted type + constructor, not the bundle required for a data constructor. + (GHC.Types.TyThing.implicitTyConThings) + +-} + warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn) -> SrcSpan -> RnM () diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index e4f11fa3fd..edc0af5f52 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -2198,9 +2198,13 @@ packageImportErr -- We can get an operator as the constructor, even in the prefix form: -- data T = :% Int Int -- from interface files, which always print in prefix form +-- +-- We also allow type constructor names, which are defined by "type data" +-- declarations. See Note [Type data declarations] in GHC.Rename.Module. checkConName :: RdrName -> TcRn () -checkConName name = checkErr (isRdrDataCon name) (badDataCon name) +checkConName name + = checkErr (isRdrDataCon name || isRdrTc name) (badDataCon name) badDataCon :: RdrName -> TcRnMessage badDataCon name diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index ab338cf452..3f6989e9f9 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -994,6 +994,13 @@ instance Diagnostic TcRnMessage where text "No explicit" <+> text "associated type" <+> text "or default declaration for" <+> quotes (ppr name) + TcRnIllegalTypeData + -> mkSimpleDecorated $ + text "Illegal type-level data declaration" + TcRnTypeDataForbids feature + -> mkSimpleDecorated $ + ppr feature <+> text "are not allowed in type data declarations." + diagnosticReason = \case TcRnUnknownMessage m -> diagnosticReason m @@ -1323,6 +1330,10 @@ instance Diagnostic TcRnMessage where -> ErrorWithoutFlag TcRnNoExplicitAssocTypeOrDefaultDeclaration{} -> WarningWithFlag (Opt_WarnMissingMethods) + TcRnIllegalTypeData + -> ErrorWithoutFlag + TcRnTypeDataForbids{} + -> ErrorWithoutFlag diagnosticHints = \case TcRnUnknownMessage m @@ -1655,6 +1666,10 @@ instance Diagnostic TcRnMessage where -> noHints TcRnNoExplicitAssocTypeOrDefaultDeclaration{} -> noHints + TcRnIllegalTypeData + -> [suggestExtension LangExt.TypeData] + TcRnTypeDataForbids{} + -> noHints diagnosticCode = constructorCode diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs index 16d91f1c44..a2daa7d900 100644 --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -7,6 +7,7 @@ module GHC.Tc.Errors.Types ( TcRnMessage(..) , mkTcRnUnknownMessage , TcRnMessageDetailed(..) + , TypeDataForbids(..) , ErrInfo(..) , FixedRuntimeRepProvenance(..) , pprFixedRuntimeRepProvenance @@ -2288,8 +2289,48 @@ data TcRnMessage where :: Name -> TcRnMessage + {-| TcRnIllegalTypeData is an error that occurs when a @type data@ + declaration occurs without the TypeOperators extension. + + See Note [Type data declarations] + + Test case: + testsuite/tests/type-data/should_fail/TDNoPragma + -} + TcRnIllegalTypeData :: TcRnMessage + + {-| TcRnTypeDataForbids is an error that occurs when a @type data@ + declaration contains @data@ declaration features that are + forbidden in a @type data@ declaration. + + See Note [Type data declarations] + + Test cases: + testsuite/tests/type-data/should_fail/TDDeriving + testsuite/tests/type-data/should_fail/TDRecordsGADT + testsuite/tests/type-data/should_fail/TDRecordsH98 + testsuite/tests/type-data/should_fail/TDStrictnessGADT + testsuite/tests/type-data/should_fail/TDStrictnessH98 + -} + TcRnTypeDataForbids :: !TypeDataForbids -> TcRnMessage + deriving Generic +-- | Things forbidden in @type data@ declarations. +-- See Note [Type data declarations] +data TypeDataForbids + = TypeDataForbidsDatatypeContexts + | TypeDataForbidsLabelledFields + | TypeDataForbidsStrictnessAnnotations + | TypeDataForbidsDerivingClauses + deriving Generic + +instance Outputable TypeDataForbids where + ppr TypeDataForbidsDatatypeContexts = text "Data type contexts" + ppr TypeDataForbidsLabelledFields = text "Labelled fields" + ppr TypeDataForbidsStrictnessAnnotations = text "Strictness flags" + ppr TypeDataForbidsDerivingClauses = text "Deriving clauses" + -- | Specifies which back ends can handle a requested foreign import or export type ExpectedBackends = [Backend] -- | Specifies which calling convention is unsupported on the current platform diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index d0eb6337ef..3539b6e0e5 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -1287,9 +1287,15 @@ mk_prom_err_env (DataDecl { tcdLName = L _ name , tcdDataDefn = HsDataDefn { dd_cons = cons } }) = unitNameEnv name (APromotionErr TyConPE) `plusNameEnv` - mkNameEnv [ (con, APromotionErr RecDataConPE) + mkNameEnv [ (con, APromotionErr conPE) | L _ con' <- toList cons , L _ con <- getConNames con' ] + where + -- In a "type data" declaration, the constructors are at the type level. + -- See Note [Type data declarations] in GHC.Rename.Module. + conPE + | isTypeDataDefnCons cons = TyConPE + | otherwise = RecDataConPE mk_prom_err_env decl = unitNameEnv (tcdName decl) (APromotionErr TyConPE) @@ -1788,6 +1794,9 @@ mappings: APromotionErr is only used for DataCons, and only used during type checking in tcTyClGroup. +The same restriction applies constructors in to "type data" declarations. +See Note [Type data declarations] in GHC.Rename.Module. + ************************************************************************ * * @@ -2952,17 +2961,17 @@ 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 (DataTypeCons []) = 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) _ (DataTypeCons []) + mk_tc_rhs (isHsBootOrSig -> True) _ (DataTypeCons _ []) = return AbstractTyCon mk_tc_rhs _ tycon data_cons = case data_cons of - DataTypeCons data_cons -> return $ + DataTypeCons _ data_cons -> return $ mkLevPolyDataTyConRhs (isFixedRuntimeRepKind (tyConResKind tycon)) data_cons @@ -3367,7 +3376,7 @@ 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 + DataTypeCons is_type_data as -> DataTypeCons is_type_data <$> concatMapM (fmap toList . f DataType) as tcConDecl :: NewOrData -> DataDeclInfo @@ -4415,6 +4424,14 @@ checkValidDataCon dflags existential_ok tc con ; checkTc (existential_ok || isVanillaDataCon con) (badExistential con) + -- Check that the only constraints in signatures of constructors + -- in a "type data" declaration are equality constraints. + -- See Note [Type data declarations] in GHC.Rename.Module, + -- restriction (R4). + ; when (isTypeDataCon con) $ + checkTc (all isEqPred (dataConOtherTheta con)) + (TcRnConstraintInKind (dataConRepType con)) + -- Check that UNPACK pragmas and bangs work out -- E.g. reject data T = MkT {-# UNPACK #-} Int -- No "!" -- data T = MkT {-# UNPACK #-} !a -- Can't unpack diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 32d710dec7..e1b7fc0f0f 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -772,7 +772,7 @@ tcDataFamInstDecl mb_clsinfo tv_skol_env ; rep_tc_name <- newFamInstTyConName lfam_name pats ; axiom_name <- newFamInstAxiomName lfam_name [pats] ; tc_rhs <- case data_cons of - DataTypeCons data_cons -> return $ + DataTypeCons _ data_cons -> return $ mkLevPolyDataTyConRhs (isFixedRuntimeRepKind res_kind) data_cons diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index f7ba81db6b..47e8b5758c 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -294,7 +294,8 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs) , dd_cType = Nothing , dd_ctxt = mkHsContextMaybe ctxt' , dd_kindSig = ksig' - , dd_cons = DataTypeCons cons', dd_derivs = derivs' } + , dd_cons = DataTypeCons False cons' + , dd_derivs = derivs' } ; returnJustLA $ TyClD noExtField $ DataDecl { tcdDExt = noAnn , tcdLName = tc', tcdTyVars = tvs' @@ -381,7 +382,8 @@ cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs) , dd_cType = Nothing , dd_ctxt = mkHsContextMaybe ctxt' , dd_kindSig = ksig' - , dd_cons = DataTypeCons cons', dd_derivs = derivs' } + , dd_cons = DataTypeCons False cons' + , dd_derivs = derivs' } ; returnJustLA $ InstD noExtField $ DataFamInstD { dfid_ext = noExtField diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs index 639863c630..58353483dc 100644 --- a/compiler/GHC/Types/Error/Codes.hs +++ b/compiler/GHC/Types/Error/Codes.hs @@ -466,6 +466,8 @@ type family GhcDiagnosticCode c = n | n -> c where GhcDiagnosticCode "TcRnIgnoreSpecialisePragmaOnDefMethod" = 72520 GhcDiagnosticCode "TcRnBadMethodErr" = 46284 GhcDiagnosticCode "TcRnNoExplicitAssocTypeOrDefaultDeclaration" = 08585 + GhcDiagnosticCode "TcRnIllegalTypeData" = 15013 + GhcDiagnosticCode "TcRnTypeDataForbids" = 67297 -- TcRnPragmaWarning GhcDiagnosticCode "WarningTxt" = 63394 diff --git a/compiler/GHC/Types/TyThing.hs b/compiler/GHC/Types/TyThing.hs index 8a12506a63..628d8da801 100644 --- a/compiler/GHC/Types/TyThing.hs +++ b/compiler/GHC/Types/TyThing.hs @@ -183,9 +183,8 @@ implicitTyConThings tc implicitCoTyCon tc ++ -- for each data constructor in order, - -- the constructor, worker, and (possibly) wrapper - [ thing | dc <- tyConDataCons tc - , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ] + -- the constructor and associated implicit 'Id's + concatMap datacon_stuff (tyConDataCons tc) -- NB. record selectors are *not* implicit, they have fully-fledged -- bindings that pass through the compilation pipeline as normal. where @@ -193,6 +192,17 @@ implicitTyConThings tc Nothing -> [] Just cl -> implicitClassThings cl + -- For each data constructor, + -- the constructor, worker, and (possibly) wrapper + -- + -- If the data constructor is in a "type data" declaration, + -- promote it to the type level now. + -- See Note [Type data declarations] in GHC.Rename.Module. + datacon_stuff dc + | isTypeDataCon dc = [ATyCon (promoteDataCon dc)] + | otherwise + = AConLike (RealDataCon dc) : dataConImplicitTyThings dc + -- For newtypes and closed type families (only) add the implicit coercion tycon implicitCoTyCon :: TyCon -> [TyThing] implicitCoTyCon tc diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs index e7c23f84cf..af8c0bb1e9 100644 --- a/compiler/Language/Haskell/Syntax/Decls.hs +++ b/compiler/Language/Haskell/Syntax/Decls.hs @@ -16,7 +16,7 @@ {- (c) The University of Glasgow 2006 -(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +(c) The GRASP/@type@AQUA Project, Glasgow University, 1992-1998 -} @@ -33,6 +33,7 @@ module Language.Haskell.Syntax.Decls ( HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, FunDep(..), HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys, NewOrData(..), DataDefnCons(..), dataDefnConsNewOrData, + isTypeDataDefnCons, StandaloneKindSig(..), LStandaloneKindSig, -- ** Class or type declarations @@ -991,16 +992,28 @@ data NewOrData | DataType -- ^ @data Blah ...@ deriving ( Eq, Data ) -- Needed because Demand derives Eq --- | Whether a data-type declaration is `data` or `newtype`, and its constructors +-- | Whether a data-type declaration is @data@ or @newtype@, and its constructors. data DataDefnCons a - = NewTypeCon a -- ^ @newtype Blah ...@ - | DataTypeCons [a] -- ^ @data Blah ...@ + = NewTypeCon -- @newtype N x = MkN blah@ + a -- Info about the single data constructor @MkN@ + + | DataTypeCons + Bool -- True <=> type data T x = ... + -- See Note [Type data declarations] in GHC.Rename.Module + -- False <=> data T x = ... + [a] -- The (possibly empty) list of data constructors deriving ( Eq, Data, Foldable, Functor, Traversable ) -- Needed because Demand derives Eq dataDefnConsNewOrData :: DataDefnCons a -> NewOrData dataDefnConsNewOrData = \ case NewTypeCon _ -> NewType - DataTypeCons _ -> DataType + DataTypeCons _ _ -> DataType + +-- | Are the constructors within a @type data@ declaration? +-- See Note [Type data declarations] in GHC.Rename.Module. +isTypeDataDefnCons :: DataDefnCons a -> Bool +isTypeDataDefnCons (NewTypeCon _) = False +isTypeDataDefnCons (DataTypeCons is_type_data _) = is_type_data -- | Located data Constructor Declaration type LConDecl pass = XRec pass (ConDecl pass) diff --git a/docs/users_guide/9.6.1-notes.rst b/docs/users_guide/9.6.1-notes.rst index 355fc63838..f66ba9e06a 100644 --- a/docs/users_guide/9.6.1-notes.rst +++ b/docs/users_guide/9.6.1-notes.rst @@ -62,6 +62,12 @@ Language - Error messages are now assigned unique error codes, of the form ``[GHC-12345]``. +- GHC Proposal `#106 + <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0106-type-data.rst>`_ + has been implemented, introducing a new language extension + :extension:`TypeData`. This extension permits ``type data`` declarations + as a more fine-grained alternative to :extension:`DataKinds`. + Compiler ~~~~~~~~ diff --git a/docs/users_guide/exts/data_kinds.rst b/docs/users_guide/exts/data_kinds.rst index 50816cbb53..bf99065907 100644 --- a/docs/users_guide/exts/data_kinds.rst +++ b/docs/users_guide/exts/data_kinds.rst @@ -15,6 +15,7 @@ system that complements kind polymorphism. It is enabled by :extension:`DataKinds`, and described in more detail in the paper `Giving Haskell a Promotion <https://dreixel.net/research/pdf/ghp.pdf>`__, which appeared at TLDI 2012. +See also :extension:`TypeData` for a more fine-grained alternative. Motivation ---------- diff --git a/docs/users_guide/exts/type_data.rst b/docs/users_guide/exts/type_data.rst new file mode 100644 index 0000000000..0779b23273 --- /dev/null +++ b/docs/users_guide/exts/type_data.rst @@ -0,0 +1,60 @@ +Type-level data declarations +============================ + +.. extension:: TypeData + :shortdesc: Enable type data declarations. + + :since: 9.6.1 + + Allow ``type data`` declarations, which define constructors at the type level. + +This extension facilitates type-level (compile-time) programming by +allowing a type-level counterpart of ``data`` declarations, such as this +definition of type-level natural numbers: :: + + type data Nat = Zero | Succ Nat + +This is similar to the corresponding ``data`` declaration, except that +the constructors ``Zero`` and ``Succ`` it introduces belong to the type +constructor namespace, so they can be used in types, such as the type +of length-indexed vectors: :: + + data Vec :: Type -> Nat -> Type where + Nil :: Vec a Zero + Cons :: a -> Vec a n -> Vec a (Succ n) + +:extension:`TypeData` is a more fine-grained alternative to the +:extension:`DataKinds` extension, which defines *all* the constructors +in *all* ``data`` declarations as both data constructors and type +constructors. + +A ``type data`` declaration has the same syntax as a ``data`` declaration, +either an ordinary algebraic data type or a GADT, prefixed with the keyword +``type``, except that it may not contain +a datatype context (even with :extension:`DatatypeContexts`), +labelled fields, +strictness flags, or +a ``deriving`` clause. + +The only constraints permitted in the types of constructors are +equality constraints, e.g.: :: + + type data P :: Type -> Type -> Type where + MkP :: (a ~ Natural, b ~~ Char) => P a b + +Because ``type data`` declarations introduce type constructors, they do +not permit constructors with the same names as types, so the following +declaration is invalid: :: + + type data T = T // Invalid + +The compiler will reject this declaration, because the type constructor +``T`` is defined twice (as the datatype being defined and as a type +constructor). + +The main type constructor of a ``type data`` declaration can be defined +recursively, as in the ``Nat`` example above, but its constructors may not +be used in types within the same mutually recursive group of declarations, +so the following is forbidden: :: + + type data T f = K (f (K Int)) // Invalid diff --git a/docs/users_guide/exts/types.rst b/docs/users_guide/exts/types.rst index 23f0c118ab..ea85223184 100644 --- a/docs/users_guide/exts/types.rst +++ b/docs/users_guide/exts/types.rst @@ -16,6 +16,7 @@ Types gadt type_families data_kinds + type_data poly_kinds representation_polymorphism type_literals diff --git a/libraries/Cabal b/libraries/Cabal -Subproject dac10555299fa0d750838529a67598821264e5e +Subproject 410f871df899e5af0847089354e0031fe051551 diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs index 0fd00b2c40..e0a1d7a2a5 100644 --- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs @@ -73,6 +73,7 @@ data Extension | ConstraintKinds | PolyKinds -- Kind polymorphism | DataKinds -- Datatype promotion + | TypeData -- allow @type data@ definitions | InstanceSigs | ApplicativeDo | LinearTypes diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index c25c3b7f1c..d8cf02218c 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -38,6 +38,7 @@ check title expected got expectedGhcOnlyExtensions :: [String] expectedGhcOnlyExtensions = [ "DeepSubsumption" + , "TypeData" ] expectedCabalOnlyExtensions :: [String] diff --git a/testsuite/tests/ghc-api/exactprint/Test20239.stderr b/testsuite/tests/ghc-api/exactprint/Test20239.stderr index 60ff0ec324..2bac5ab532 100644 --- a/testsuite/tests/ghc-api/exactprint/Test20239.stderr +++ b/testsuite/tests/ghc-api/exactprint/Test20239.stderr @@ -111,6 +111,7 @@ (Nothing) (Nothing) (DataTypeCons + (False) [(L (SrcSpanAnn (EpAnn (Anchor diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr index de2f98d899..257d03eb20 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr @@ -840,6 +840,7 @@ (Nothing) (Nothing) (DataTypeCons + (False) [(L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:25:5-18 }) (ConDeclGADT @@ -1108,6 +1109,7 @@ (Nothing) (Nothing) (DataTypeCons + (False) [(L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:31:5-18 }) (ConDeclGADT @@ -1376,6 +1378,7 @@ (Nothing) (Nothing) (DataTypeCons + (False) [(L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:37:5-18 }) (ConDeclGADT @@ -1644,6 +1647,7 @@ (Nothing) (Nothing) (DataTypeCons + (False) [(L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:43:5-18 }) (ConDeclGADT @@ -1912,6 +1916,7 @@ (Nothing) (Nothing) (DataTypeCons + (False) [(L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:49:5-18 }) (ConDeclGADT @@ -2180,6 +2185,7 @@ (Nothing) (Nothing) (DataTypeCons + (False) [(L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:55:5-20 }) (ConDeclGADT diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr index e00ee8798a..efc2c927ae 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr @@ -83,6 +83,7 @@ (Nothing) (Nothing) (DataTypeCons + (False) [(L (SrcSpanAnn (EpAnnNotUsed) { T17544_kw.hs:16:9-20 }) (ConDeclGADT diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index 926d97fb35..fdea6a5bce 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -98,6 +98,7 @@ (Nothing) (Nothing) (DataTypeCons + (False) [(L (SrcSpanAnn (EpAnn (Anchor @@ -536,6 +537,7 @@ (Nothing) (Nothing) (DataTypeCons + (False) [(L (SrcSpanAnn (EpAnnNotUsed) { DumpParsedAst.hs:15:21-29 }) (ConDeclH98 diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index 88f23d3ee0..d3b7566f5d 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -113,6 +113,7 @@ (Nothing) (Nothing) (DataTypeCons + (False) [(L (SrcSpanAnn (EpAnn (Anchor @@ -788,6 +789,7 @@ (Nothing) (Nothing) (DataTypeCons + (False) [(L (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:22:21-29 }) (ConDeclH98 diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr index 29225d7f00..caede8b720 100644 --- a/testsuite/tests/parser/should_compile/T14189.stderr +++ b/testsuite/tests/parser/should_compile/T14189.stderr @@ -39,6 +39,7 @@ (Nothing) (Nothing) (DataTypeCons + (False) [(L (SrcSpanAnn (EpAnn (Anchor diff --git a/testsuite/tests/parser/should_compile/T15323.stderr b/testsuite/tests/parser/should_compile/T15323.stderr index fbcfa63276..36768671e4 100644 --- a/testsuite/tests/parser/should_compile/T15323.stderr +++ b/testsuite/tests/parser/should_compile/T15323.stderr @@ -85,6 +85,7 @@ (Nothing) (Nothing) (DataTypeCons + (False) [(L (SrcSpanAnn (EpAnnNotUsed) { T15323.hs:6:5-54 }) (ConDeclGADT diff --git a/testsuite/tests/parser/should_compile/T20452.stderr b/testsuite/tests/parser/should_compile/T20452.stderr index c7808c1019..8cbc6e13c2 100644 --- a/testsuite/tests/parser/should_compile/T20452.stderr +++ b/testsuite/tests/parser/should_compile/T20452.stderr @@ -102,6 +102,7 @@ (Nothing) (Nothing) (DataTypeCons + (False) [(L (SrcSpanAnn (EpAnnNotUsed) { T20452.hs:5:26-31 }) (ConDeclH98 @@ -191,6 +192,7 @@ (Nothing) (Nothing) (DataTypeCons + (False) [(L (SrcSpanAnn (EpAnnNotUsed) { T20452.hs:6:26-31 }) (ConDeclH98 diff --git a/testsuite/tests/printer/T18791.stderr b/testsuite/tests/printer/T18791.stderr index 2d8d3060ab..52c97faba4 100644 --- a/testsuite/tests/printer/T18791.stderr +++ b/testsuite/tests/printer/T18791.stderr @@ -71,6 +71,7 @@ (Nothing) (Nothing) (DataTypeCons + (False) [(L (SrcSpanAnn (EpAnnNotUsed) { T18791.hs:5:3-17 }) (ConDeclGADT diff --git a/testsuite/tests/type-data/Makefile b/testsuite/tests/type-data/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/type-data/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/type-data/should_compile/Makefile b/testsuite/tests/type-data/should_compile/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/type-data/should_compile/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/type-data/should_compile/TDDataConstructor.hs b/testsuite/tests/type-data/should_compile/TDDataConstructor.hs new file mode 100644 index 0000000000..8474ec25eb --- /dev/null +++ b/testsuite/tests/type-data/should_compile/TDDataConstructor.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeData #-} +module TDDataConstructor where + +type data P = MkP +data Prom = P diff --git a/testsuite/tests/type-data/should_compile/TDExistential.hs b/testsuite/tests/type-data/should_compile/TDExistential.hs new file mode 100644 index 0000000000..0e9bb04014 --- /dev/null +++ b/testsuite/tests/type-data/should_compile/TDExistential.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeData #-} +{-# LANGUAGE TypeFamilies #-} +module TDExistential where + +import Data.Kind (Type) + +-- example from GHC User's Guide 6.4.10.6 + +type data Ex :: Type where + MkEx :: forall a. a -> Ex + +type family UnEx (ex :: Ex) :: k +type instance UnEx (MkEx x) = x diff --git a/testsuite/tests/type-data/should_compile/TDGoodConsConstraints.hs b/testsuite/tests/type-data/should_compile/TDGoodConsConstraints.hs new file mode 100644 index 0000000000..0b4e006184 --- /dev/null +++ b/testsuite/tests/type-data/should_compile/TDGoodConsConstraints.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeData #-} +{-# LANGUAGE GADTs #-} +module TDGoodConsConstraints where + +import Data.Kind (Type) +import Data.Type.Equality + +type data Foo :: Type -> Type where + MkFoo1 :: a ~ Int => Foo a + MkFoo2 :: a ~~ Int => Foo a diff --git a/testsuite/tests/type-data/should_compile/TDVector.hs b/testsuite/tests/type-data/should_compile/TDVector.hs new file mode 100644 index 0000000000..753cd97375 --- /dev/null +++ b/testsuite/tests/type-data/should_compile/TDVector.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TypeData #-} +{-# LANGUAGE MonoLocalBinds #-} +module TDVector where + +import Data.Kind (Type) + +type data Nat = Zero | Succ Nat + +type data List a = Nil | Cons a (List a) + +type data Pair a b = MkPair a b + +type data Sum a b = L a | R b + +data Vec :: Nat -> Type -> Type where + VNil :: Vec Zero a + VCons :: a -> Vec n a -> Vec (Succ n) a + +instance Functor (Vec n) where + fmap _ VNil = VNil + fmap f (VCons x xs) = VCons (f x) (fmap f xs) diff --git a/testsuite/tests/type-data/should_compile/all.T b/testsuite/tests/type-data/should_compile/all.T new file mode 100644 index 0000000000..0f8294bee7 --- /dev/null +++ b/testsuite/tests/type-data/should_compile/all.T @@ -0,0 +1,4 @@ +test('TDDataConstructor', normal, compile, ['']) +test('TDExistential', normal, compile, ['']) +test('TDGoodConsConstraints', normal, compile, ['']) +test('TDVector', normal, compile, ['']) diff --git a/testsuite/tests/type-data/should_fail/Makefile b/testsuite/tests/type-data/should_fail/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/type-data/should_fail/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/type-data/should_fail/TDBadConsConstraint.hs b/testsuite/tests/type-data/should_fail/TDBadConsConstraint.hs new file mode 100644 index 0000000000..43a709f516 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDBadConsConstraint.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeData #-} +{-# LANGUAGE GADTs #-} +module TDConsConstraints where + +import Data.Kind (Type) + +type data Foo :: Type -> Type where + MkFoo3 :: Show a => Foo a diff --git a/testsuite/tests/type-data/should_fail/TDBadConsConstraint.stderr b/testsuite/tests/type-data/should_fail/TDBadConsConstraint.stderr new file mode 100644 index 0000000000..1e2eddc456 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDBadConsConstraint.stderr @@ -0,0 +1,5 @@ + +TDBadConsConstraint.hs:8:3: [GHC-01259] + Illegal constraint in a kind: forall a. Show a => Foo a + In the definition of data constructor ‘MkFoo3’ + In the data type declaration for ‘Foo’ diff --git a/testsuite/tests/type-data/should_fail/TDDeriving.hs b/testsuite/tests/type-data/should_fail/TDDeriving.hs new file mode 100644 index 0000000000..dc804fc532 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDDeriving.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeData #-} +module TDDeriving where + +type data Nat = Zero | Succ Nat + deriving (Eq) diff --git a/testsuite/tests/type-data/should_fail/TDDeriving.stderr b/testsuite/tests/type-data/should_fail/TDDeriving.stderr new file mode 100644 index 0000000000..231f2c7df7 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDDeriving.stderr @@ -0,0 +1,3 @@ + +TDDeriving.hs:4:1: [GHC-67297] + Deriving clauses are not allowed in type data declarations. diff --git a/testsuite/tests/type-data/should_fail/TDExpression.hs b/testsuite/tests/type-data/should_fail/TDExpression.hs new file mode 100644 index 0000000000..4f04993459 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDExpression.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeData #-} +module TDExpression where + +type data Nat = Zero | Succ Nat + +-- Not in scope: data constructor ‘Zero’ +z = Zero diff --git a/testsuite/tests/type-data/should_fail/TDExpression.stderr b/testsuite/tests/type-data/should_fail/TDExpression.stderr new file mode 100644 index 0000000000..354dac183f --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDExpression.stderr @@ -0,0 +1,6 @@ + +TDExpression.hs:7:5: [GHC-31891] + Illegal term-level use of the type constructor or class ‘Zero’ + defined at TDExpression.hs:4:17 + In the expression: Zero + In an equation for ‘z’: z = Zero diff --git a/testsuite/tests/type-data/should_fail/TDMultiple01.hs b/testsuite/tests/type-data/should_fail/TDMultiple01.hs new file mode 100644 index 0000000000..ead94c4d1d --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDMultiple01.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeData #-} +module TDMultiple01 where + +data P = MkP +type data Prom = P -- P is multiply defined diff --git a/testsuite/tests/type-data/should_fail/TDMultiple01.stderr b/testsuite/tests/type-data/should_fail/TDMultiple01.stderr new file mode 100644 index 0000000000..5b3abe33ed --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDMultiple01.stderr @@ -0,0 +1,5 @@ + +TDMultiple01.hs:5:18: + Multiple declarations of ‘P’ + Declared at: TDMultiple01.hs:4:1 + TDMultiple01.hs:5:18 diff --git a/testsuite/tests/type-data/should_fail/TDMultiple02.hs b/testsuite/tests/type-data/should_fail/TDMultiple02.hs new file mode 100644 index 0000000000..91dcf565f7 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDMultiple02.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeData #-} +module TDMultiple02 where + +type data P = MkP +type data Prom = P -- type P is multiply defined diff --git a/testsuite/tests/type-data/should_fail/TDMultiple02.stderr b/testsuite/tests/type-data/should_fail/TDMultiple02.stderr new file mode 100644 index 0000000000..c08709fa8c --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDMultiple02.stderr @@ -0,0 +1,5 @@ + +TDMultiple02.hs:5:18: + Multiple declarations of ‘P’ + Declared at: TDMultiple02.hs:4:1 + TDMultiple02.hs:5:18 diff --git a/testsuite/tests/type-data/should_fail/TDNoPragma.hs b/testsuite/tests/type-data/should_fail/TDNoPragma.hs new file mode 100644 index 0000000000..a1b5386f62 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDNoPragma.hs @@ -0,0 +1,4 @@ +module TDNoPragma where + +-- requires LANGUAGE TypeData +type data Nat = Zero | Succ Nat diff --git a/testsuite/tests/type-data/should_fail/TDNoPragma.stderr b/testsuite/tests/type-data/should_fail/TDNoPragma.stderr new file mode 100644 index 0000000000..62b47da4d1 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDNoPragma.stderr @@ -0,0 +1,4 @@ + +TDNoPragma.hs:4:1: [GHC-15013] + Illegal type-level data declaration + Suggested fix: Perhaps you intended to use TypeData diff --git a/testsuite/tests/type-data/should_fail/TDPattern.hs b/testsuite/tests/type-data/should_fail/TDPattern.hs new file mode 100644 index 0000000000..abcf65de24 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDPattern.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeData #-} +module TDPattern where + +type data Nat = Zero | Succ Nat + +-- Zero is not a data constructor +f Zero = 0 diff --git a/testsuite/tests/type-data/should_fail/TDPattern.stderr b/testsuite/tests/type-data/should_fail/TDPattern.stderr new file mode 100644 index 0000000000..3fecbb1f6b --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDPattern.stderr @@ -0,0 +1,3 @@ + +TDPattern.hs:7:3: [GHC-76037] + Not in scope: data constructor ‘Zero’ diff --git a/testsuite/tests/type-data/should_fail/TDPunning.hs b/testsuite/tests/type-data/should_fail/TDPunning.hs new file mode 100644 index 0000000000..0560009ce8 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDPunning.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TypeData #-} +module TDPunning where + +type data T = T -- type T is multiply defined diff --git a/testsuite/tests/type-data/should_fail/TDPunning.stderr b/testsuite/tests/type-data/should_fail/TDPunning.stderr new file mode 100644 index 0000000000..95ddbf51d3 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDPunning.stderr @@ -0,0 +1,5 @@ + +TDPunning.hs:4:15: + Multiple declarations of ‘T’ + Declared at: TDPunning.hs:4:1 + TDPunning.hs:4:15 diff --git a/testsuite/tests/type-data/should_fail/TDRecordsGADT.hs b/testsuite/tests/type-data/should_fail/TDRecordsGADT.hs new file mode 100644 index 0000000000..0d9e6536c3 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDRecordsGADT.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeData #-} +{-# LANGUAGE GADTs #-} +module TDRecordsGADT where + +type data Record a where + Cons :: { field :: a } -> Record a diff --git a/testsuite/tests/type-data/should_fail/TDRecordsGADT.stderr b/testsuite/tests/type-data/should_fail/TDRecordsGADT.stderr new file mode 100644 index 0000000000..8695163190 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDRecordsGADT.stderr @@ -0,0 +1,3 @@ + +TDRecordsGADT.hs:6:5: [GHC-67297] + Labelled fields are not allowed in type data declarations. diff --git a/testsuite/tests/type-data/should_fail/TDRecordsH98.hs b/testsuite/tests/type-data/should_fail/TDRecordsH98.hs new file mode 100644 index 0000000000..d6d805532f --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDRecordsH98.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TypeData #-} +module TDRecordsH98 where + +type data Record a = Cons { field :: a } diff --git a/testsuite/tests/type-data/should_fail/TDRecordsH98.stderr b/testsuite/tests/type-data/should_fail/TDRecordsH98.stderr new file mode 100644 index 0000000000..c20a83dc73 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDRecordsH98.stderr @@ -0,0 +1,3 @@ + +TDRecordsH98.hs:4:22: [GHC-67297] + Labelled fields are not allowed in type data declarations. diff --git a/testsuite/tests/type-data/should_fail/TDRecursive.hs b/testsuite/tests/type-data/should_fail/TDRecursive.hs new file mode 100644 index 0000000000..b4a09c165e --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDRecursive.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TypeData #-} +module TDRecursive where + +type data T f = K (f (K Int)) diff --git a/testsuite/tests/type-data/should_fail/TDRecursive.stderr b/testsuite/tests/type-data/should_fail/TDRecursive.stderr new file mode 100644 index 0000000000..8225bd1790 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDRecursive.stderr @@ -0,0 +1,7 @@ + +TDRecursive.hs:4:23: [GHC-88634] + Type constructor ‘K’ cannot be used here + (it is defined and used in the same recursive group) + In the first argument of ‘f’, namely ‘(K Int)’ + In the type ‘(f (K Int))’ + In the definition of data constructor ‘K’ diff --git a/testsuite/tests/type-data/should_fail/TDStrictnessGADT.hs b/testsuite/tests/type-data/should_fail/TDStrictnessGADT.hs new file mode 100644 index 0000000000..774c560e30 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDStrictnessGADT.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeData #-} +module TDStrictnessGADT where + +type data T a where + Cons :: !a -> T a diff --git a/testsuite/tests/type-data/should_fail/TDStrictnessGADT.stderr b/testsuite/tests/type-data/should_fail/TDStrictnessGADT.stderr new file mode 100644 index 0000000000..db235cd048 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDStrictnessGADT.stderr @@ -0,0 +1,3 @@ + +TDStrictnessGADT.hs:5:6: [GHC-67297] + Strictness flags are not allowed in type data declarations. diff --git a/testsuite/tests/type-data/should_fail/TDStrictnessH98.hs b/testsuite/tests/type-data/should_fail/TDStrictnessH98.hs new file mode 100644 index 0000000000..062df5bd02 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDStrictnessH98.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE TypeData #-} +module TDStrictnessH98 where + +type data T a = Cons !a diff --git a/testsuite/tests/type-data/should_fail/TDStrictnessH98.stderr b/testsuite/tests/type-data/should_fail/TDStrictnessH98.stderr new file mode 100644 index 0000000000..e0ccd5e456 --- /dev/null +++ b/testsuite/tests/type-data/should_fail/TDStrictnessH98.stderr @@ -0,0 +1,3 @@ + +TDStrictnessH98.hs:4:17: [GHC-67297] + Strictness flags are not allowed in type data declarations. diff --git a/testsuite/tests/type-data/should_fail/all.T b/testsuite/tests/type-data/should_fail/all.T new file mode 100644 index 0000000000..ddf7bd86bd --- /dev/null +++ b/testsuite/tests/type-data/should_fail/all.T @@ -0,0 +1,13 @@ +test('TDNoPragma', normal, compile_fail, ['']) +test('TDBadConsConstraint', normal, compile_fail, ['']) +test('TDDeriving', normal, compile_fail, ['']) +test('TDExpression', normal, compile_fail, ['']) +test('TDMultiple01', normal, compile_fail, ['']) +test('TDMultiple02', normal, compile_fail, ['']) +test('TDPattern', normal, compile_fail, ['']) +test('TDPunning', normal, compile_fail, ['']) +test('TDRecordsGADT', normal, compile_fail, ['']) +test('TDRecordsH98', normal, compile_fail, ['']) +test('TDRecursive', normal, compile_fail, ['']) +test('TDStrictnessGADT', normal, compile_fail, ['']) +test('TDStrictnessH98', normal, compile_fail, ['']) diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index 277fcfcd3a..25ea557a27 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -2748,7 +2748,7 @@ exactDataDefn an exactHdr , dd_cons = condecls, dd_derivs = derivings }) = do annotationsToComments (epAnnAnns an) [AnnOpenP, AnnCloseP] markEpAnn an $ case condecls of - DataTypeCons _ -> AnnData + DataTypeCons _ _ -> AnnData NewTypeCon _ -> AnnNewtype markEpAnn an AnnInstance -- optional mapM_ markAnnotated mb_ct diff --git a/utils/haddock b/utils/haddock -Subproject f114ba7fc0751f53766e2c3089e234927237a98 +Subproject e5b41a9f92de608f3605ef54da5709074e189ad |