From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 18:34:00 +0000 (+0000) Subject: Extended TyCon and friends to represent family declarations X-Git-Tag: After_FC_branch_merge~36 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=e8a591c1a3dbdeccec2dd2aacccd7435004b0d51 Extended TyCon and friends to represent family declarations Mon Sep 18 18:50:35 EDT 2006 Manuel M T Chakravarty * Extended TyCon and friends to represent family declarations Tue Aug 15 16:52:31 EDT 2006 Manuel M T Chakravarty * Extended TyCon and friends to represent family declarations --- diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 13be049..a11b351 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -913,11 +913,12 @@ instance Binary IfaceDecl where put_ bh a6 put_ bh a7 - put_ bh (IfaceSyn aq ar as) = do + put_ bh (IfaceSyn aq ar as at) = do putByte bh 3 put_ bh aq put_ bh ar put_ bh as + put_ bh at put_ bh (IfaceClass a1 a2 a3 a4 a5 a6) = do putByte bh 4 put_ bh a1 @@ -947,7 +948,8 @@ instance Binary IfaceDecl where aq <- get bh ar <- get bh as <- get bh - return (IfaceSyn aq ar as) + at <- get bh + return (IfaceSyn aq ar as at) _ -> do a1 <- get bh a2 <- get bh @@ -983,15 +985,19 @@ instance Binary OverlapFlag where instance Binary IfaceConDecls where put_ bh IfAbstractTyCon = putByte bh 0 - put_ bh (IfDataTyCon cs) = do { putByte bh 1 + put_ bh IfOpenDataTyCon = putByte bh 1 + put_ bh IfOpenNewTyCon = putByte bh 2 + put_ bh (IfDataTyCon cs) = do { putByte bh 3 ; put_ bh cs } - put_ bh (IfNewTyCon c) = do { putByte bh 2 + put_ bh (IfNewTyCon c) = do { putByte bh 4 ; put_ bh c } get bh = do h <- getByte bh case h of 0 -> return IfAbstractTyCon - 1 -> do cs <- get bh + 1 -> return IfOpenDataTyCon + 2 -> return IfOpenNewTyCon + 3 -> do cs <- get bh return (IfDataTyCon cs) _ -> do aa <- get bh return (IfNewTyCon aa) diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index d1118c0..c669daf 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -6,7 +6,8 @@ module BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, - mkAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs + mkAbstractTyConRhs, mkOpenDataTyConRhs, mkOpenNewTyConRhs, + mkNewTyConRhs, mkDataTyConRhs ) where #include "HsVersions.h" @@ -26,14 +27,16 @@ import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, mkNewTyCoOcc ) import MkId ( mkDataConIds, mkRecordSelId, mkDictSelId ) import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) ) -import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConStupidTheta, - tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ), - isRecursiveTyCon, tyConArity, - AlgTyConRhs(..), newTyConRhs ) +import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons, + tyConStupidTheta, tyConDataCons, isNewTyCon, + mkClassTyCon, TyCon( tyConTyVars ), + isRecursiveTyCon, tyConArity, AlgTyConRhs(..), + SynTyConRhs(..), newTyConRhs ) import Type ( mkArrowKinds, liftedTypeKind, typeKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, - splitTyConApp_maybe, splitAppTy_maybe, getTyVar_maybe, - mkPredTys, mkTyVarTys, ThetaType, Type, + splitTyConApp_maybe, splitAppTy_maybe, + getTyVar_maybe, + mkPredTys, mkTyVarTys, ThetaType, Type, Kind, substTyWith, zipTopTvSubst, substTheta, mkForAllTys, mkTyConApp, mkTyVarTy ) import Coercion ( mkNewTypeCoercion ) @@ -45,8 +48,13 @@ import List ( nub ) \begin{code} ------------------------------------------------------ -buildSynTyCon name tvs rhs_ty - = mkSynTyCon name kind tvs rhs_ty +buildSynTyCon :: Name -> [TyVar] -> SynTyConRhs -> TyCon +buildSynTyCon name tvs rhs@(OpenSynTyCon rhs_ki) + = mkSynTyCon name kind tvs rhs + where + kind = mkArrowKinds (map tyVarKind tvs) rhs_ki +buildSynTyCon name tvs rhs@(SynonymTyCon rhs_ty) + = mkSynTyCon name kind tvs rhs where kind = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty) @@ -72,6 +80,12 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn mkAbstractTyConRhs :: AlgTyConRhs mkAbstractTyConRhs = AbstractTyCon +mkOpenDataTyConRhs :: AlgTyConRhs +mkOpenDataTyConRhs = OpenDataTyCon + +mkOpenNewTyConRhs :: AlgTyConRhs +mkOpenNewTyConRhs = OpenNewTyCon + mkDataTyConRhs :: [DataCon] -> AlgTyConRhs mkDataTyConRhs cons = DataTyCon { data_cons = cons, is_enum = all isNullarySrcDataCon cons } diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 330a6fc..0d649fb 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -81,9 +81,12 @@ data IfaceDecl -- imported modules may have been compiled with -- different flags to the current compilation unit - | IfaceSyn { ifName :: OccName, -- Type constructor - ifTyVars :: [IfaceTvBndr], -- Type variables - ifSynRhs :: IfaceType -- synonym expansion + | IfaceSyn { ifName :: OccName, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifOpenSyn :: Bool, -- Is an open family? + ifSynRhs :: IfaceType -- Type for an ordinary + -- synonym and kind for an + -- open family } | IfaceClass { ifCtxt :: IfaceContext, -- Context... @@ -104,11 +107,15 @@ data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType data IfaceConDecls = IfAbstractTyCon -- No info + | IfOpenDataTyCon -- Open data family + | IfOpenNewTyCon -- Open newtype family | IfDataTyCon [IfaceConDecl] -- data type decls | IfNewTyCon IfaceConDecl -- newtype decls visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] visibleIfConDecls IfAbstractTyCon = [] +visibleIfConDecls IfOpenDataTyCon = [] +visibleIfConDecls IfOpenNewTyCon = [] visibleIfConDecls (IfDataTyCon cs) = cs visibleIfConDecls (IfNewTyCon c) = [c] @@ -229,10 +236,16 @@ pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info}) pprIfaceDecl (IfaceForeign {ifName = tycon}) = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon] -pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty}) +pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, + ifOpenSyn = False, ifSynRhs = mono_ty}) = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) 4 (equals <+> ppr mono_ty) +pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, + ifOpenSyn = True, ifSynRhs = mono_ty}) + = hang (ptext SLIT("type family") <+> pprIfaceDeclHead [] tycon tyvars) + 4 (dcolon <+> ppr mono_ty) + pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, ifTyVars = tyvars, ifCons = condecls, ifRec = isrec}) @@ -241,8 +254,10 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, where pp_nd = case condecls of IfAbstractTyCon -> ptext SLIT("data") + IfOpenDataTyCon -> ptext SLIT("data family") IfDataTyCon _ -> ptext SLIT("data") IfNewTyCon _ -> ptext SLIT("newtype") + IfOpenNewTyCon -> ptext SLIT("newtype family") pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, ifFDs = fds, ifSigs = sigs, ifRec = isrec}) @@ -262,7 +277,9 @@ pprIfaceDeclHead context thing tyvars = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), pprIfaceTvBndrs tyvars] pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}") +pp_condecls tc IfOpenNewTyCon = empty pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c +pp_condecls tc IfOpenDataTyCon = empty pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map (pprIfaceConDecl tc) cs)) @@ -556,6 +573,8 @@ eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2 eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal +eq_hsCD env IfOpenDataTyCon IfOpenDataTyCon = Equal +eq_hsCD env IfOpenNewTyCon IfOpenNewTyCon = Equal eq_hsCD env d1 d2 = NotEqual eq_ConDecl env c1 c2 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index fa91a0a..7901f7c 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -185,7 +185,8 @@ import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), import NewDemand ( isTopSig ) import CoreSyn import Class ( classExtraBigSig, classTyCon ) -import TyCon ( TyCon, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon, +import TyCon ( TyCon, AlgTyConRhs(..), SynTyConRhs(..), + isRecursiveTyCon, isForeignTyCon, isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, isTupleTyCon, tupleTyConBoxity, tyConStupidTheta, tyConHasGenerics, synTyConRhs, isGadtSyntaxTyCon, @@ -1018,9 +1019,10 @@ tyThingToIfaceDecl ext (AClass clas) tyThingToIfaceDecl ext (ATyCon tycon) | isSynTyCon tycon - = IfaceSyn { ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs tyvars, - ifSynRhs = toIfaceType ext syn_ty } + = IfaceSyn { ifName = getOccName tycon, + ifTyVars = toIfaceTvBndrs tyvars, + ifOpenSyn = syn_isOpen, + ifSynRhs = toIfaceType ext syn_tyki } | isAlgTyCon tycon = IfaceData { ifName = getOccName tycon, @@ -1048,10 +1050,16 @@ tyThingToIfaceDecl ext (ATyCon tycon) | otherwise = pprPanic "toIfaceDecl" (ppr tycon) where tyvars = tyConTyVars tycon - syn_ty = synTyConRhs tycon - - ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) - ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) + (syn_isOpen, syn_tyki) = case synTyConRhs tycon of + OpenSynTyCon ki -> (True , ki) + SynonymTyCon ty -> (False, ty) + + ifaceConDecls (NewTyCon { data_con = con }) = + IfNewTyCon (ifaceConDecl con) + ifaceConDecls (DataTyCon { data_cons = cons }) = + IfDataTyCon (map ifaceConDecl cons) + ifaceConDecls OpenDataTyCon = IfOpenDataTyCon + ifaceConDecls OpenNewTyCon = IfOpenNewTyCon ifaceConDecls AbstractTyCon = IfAbstractTyCon -- The last case happens when a TyCon has been trimmed during tidying -- Furthermore, tyThingToIfaceDecl is also used diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 1f3c5d4..08dfe8c 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -19,8 +19,10 @@ import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, newIfaceName, newIfaceNames, ifaceExportNames ) -import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, - mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) +import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, + buildClass, + mkAbstractTyConRhs, mkOpenDataTyConRhs, + mkOpenNewTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) import TcRnMonad import Type ( liftedTypeKind, splitTyConApp, mkTyConApp, liftedTypeKindTyCon, unliftedTypeKindTyCon, @@ -28,7 +30,7 @@ import Type ( liftedTypeKind, splitTyConApp, mkTyConApp, ubxTupleKindTyCon, mkTyVarTys, ThetaType ) import TypeRep ( Type(..), PredType(..) ) -import TyCon ( TyCon, tyConName ) +import TyCon ( TyCon, tyConName, SynTyConRhs(..) ) import HscTypes ( ExternalPackageState(..), TyThing(..), tyThingClass, tyThingTyCon, ModIface(..), ModDetails(..), HomeModInfo(..), @@ -371,11 +373,13 @@ tcIfaceDecl (IfaceData {ifName = occ_name, }} tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, - ifSynRhs = rdr_rhs_ty}) + ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty}) = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name - ; rhs_ty <- tcIfaceType rdr_rhs_ty - ; return (ATyCon (buildSynTyCon tc_name tyvars rhs_ty)) + ; rhs_tyki <- tcIfaceType rdr_rhs_ty + ; let rhs = if isOpen then OpenSynTyCon rhs_tyki + else SynonymTyCon rhs_tyki + ; return (ATyCon (buildSynTyCon tc_name tyvars rhs)) } tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, @@ -413,6 +417,8 @@ tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) tcIfaceDataCons tycon_name tycon tc_tyvars if_cons = case if_cons of IfAbstractTyCon -> return mkAbstractTyConRhs + IfOpenDataTyCon -> return mkOpenDataTyConRhs + IfOpenNewTyCon -> return mkOpenNewTyConRhs IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons ; return (mkDataTyConRhs data_cons) } IfNewTyCon con -> do { data_con <- tc_con_decl con diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index be47c76..c25a617 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -109,7 +109,8 @@ module GHC ( TyCon, tyConTyVars, tyConDataCons, tyConArity, isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, - synTyConDefn, synTyConRhs, + isOpenTyCon, + synTyConDefn, synTyConType, synTyConResKind, -- ** Type variables TyVar, @@ -203,8 +204,9 @@ import Id ( Id, idType, isImplicitId, isDeadBinder, import Var ( TyVar ) import TysPrim ( alphaTyVars ) import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon, - isPrimTyCon, isFunTyCon, tyConArity, - tyConTyVars, tyConDataCons, synTyConDefn, synTyConRhs ) + isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity, + tyConTyVars, tyConDataCons, synTyConDefn, + synTyConType, synTyConResKind ) import Class ( Class, classSCTheta, classTvsFds, classMethods ) import FunDeps ( pprFundeps ) import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon, diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 6354984..4d7fd8e 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -67,7 +67,7 @@ pprTyThingHdr exts (ATyCon tyCon) = pprTyConHdr exts tyCon pprTyThingHdr exts (AClass cls) = pprClassHdr exts cls pprTyConHdr exts tyCon = - ptext keyword <+> ppr_bndr tyCon <+> hsep (map ppr vars) + addFamily (ptext keyword) <+> ppr_bndr tyCon <+> hsep (map ppr vars) where vars | GHC.isPrimTyCon tyCon || GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars @@ -77,6 +77,10 @@ pprTyConHdr exts tyCon = | GHC.isNewTyCon tyCon = SLIT("newtype") | otherwise = SLIT("data") + addFamily keytext + | GHC.isOpenTyCon tyCon = keytext <> ptext SLIT(" family") + | otherwise = keytext + pprDataConSig exts dataCon = ppr_bndr dataCon <+> dcolon <+> pprType exts (GHC.dataConType dataCon) @@ -109,8 +113,12 @@ pprType False ty = ppr (GHC.dropForAlls ty) pprTyCon exts tyCon | GHC.isSynTyCon tyCon - = let rhs_type = GHC.synTyConRhs tyCon - in hang (pprTyConHdr exts tyCon <+> equals) 2 (pprType exts rhs_type) + = if GHC.isOpenTyCon tyCon + then pprTyConHdr exts tyCon <+> dcolon <+> + pprType exts (GHC.synTyConResKind tyCon) + else + let rhs_type = GHC.synTyConType tyCon + in hang (pprTyConHdr exts tyCon <+> equals) 2 (pprType exts rhs_type) | otherwise = pprAlgTyCon exts tyCon (const True) (const True) diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 9747c22..ea29fb1 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -35,6 +35,7 @@ import RdrHsSyn ( findSplice ) import PrelNames ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN, main_RDR_Unqual ) import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv ) +import TyCon ( isOpenTyCon ) import TcHsSyn ( zonkTopDecls ) import TcExpr ( tcInferRho ) import TcRnMonad diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 73d9b5a..a823884 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -585,9 +585,12 @@ reifyTyCon tc | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False) | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc)) | isSynTyCon tc - = do { let (tvs, rhs) = synTyConDefn tc - ; rhs' <- reifyType rhs - ; return (TH.TyConI $ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') } + = case synTyConDefn tc of + Nothing -> noTH SLIT("type family") (ppr tc) + Just (tvs, rhs) -> + do { rhs' <- reifyType rhs + ; return (TH.TyConI $ + TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') } reifyTyCon tc = do { cxt <- reifyCxt (tyConStupidTheta tc) diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 8ca5b01..e87cd66 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -44,8 +44,11 @@ import Type ( PredType(..), splitTyConApp_maybe, mkTyVarTy, ) import Generics ( validGenericMethodType, canDoGenerics ) import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars ) -import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon ), - tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, +import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon, + OpenNewTyCon ), + SynTyConRhs( OpenSynTyCon, SynonymTyCon ), + tyConDataCons, mkForeignTyCon, isProductTyCon, + isRecursiveTyCon, isOpenTyCon, tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName, isNewTyCon ) import DataCon ( DataCon, dataConUserType, dataConName, @@ -583,7 +586,7 @@ tcSynDecl = tcTyVarBndrs tvs $ \ tvs' -> do { traceTc (text "tcd1" <+> ppr tc_name) ; rhs_ty' <- tcHsKindedType rhs_ty - ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty')) } + ; return (ATyCon (buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty'))) } -------------------- tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM TyThing @@ -591,18 +594,38 @@ tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM TyThing tcTyClDecl calc_isrec decl = tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl) - -- kind signature for a type functions + -- kind signature for a type function tcTyClDecl1 _calc_isrec (TyFunction {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = kind}) - = tcKindSigDecl tc_name tvs kind + = tcTyVarBndrs tvs $ \ tvs' -> do + { gla_exts <- doptM Opt_GlasgowExts + + -- Check that we don't use kind signatures without Glasgow extensions + ; checkTc gla_exts $ badSigTyDecl tc_name + + ; return (ATyCon (buildSynTyCon tc_name tvs' (OpenSynTyCon kind))) + } -- kind signature for an indexed data type tcTyClDecl1 _calc_isrec - (TyData {tcdCtxt = ctxt, tcdTyVars = tvs, - tcdLName = L _ tc_name, tcdKindSig = Just kind, tcdCons = []}) - = do - { checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name - ; tcKindSigDecl tc_name tvs kind + (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, + tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = []}) + = tcTyVarBndrs tvs $ \ tvs' -> do + { extra_tvs <- tcDataKindSig mb_ksig + ; let final_tvs = tvs' ++ extra_tvs -- we may not need these + + ; checkTc (null . unLoc $ ctxt) $ badKindSigCtxt tc_name + ; gla_exts <- doptM Opt_GlasgowExts + + -- Check that we don't use kind signatures without Glasgow extensions + ; checkTc gla_exts $ badSigTyDecl tc_name + + ; tycon <- buildAlgTyCon tc_name final_tvs [] + (case new_or_data of + DataType -> OpenDataTyCon + NewType -> OpenNewTyCon) + Recursive False True + ; return (ATyCon tycon) } tcTyClDecl1 calc_isrec @@ -689,28 +712,6 @@ tcTyClDecl1 calc_isrec = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)) ----------------------------------- -tcKindSigDecl :: Name -> [LHsTyVarBndr Name] -> Kind -> TcM TyThing -tcKindSigDecl tc_name tvs kind - = tcTyVarBndrs tvs $ \ tvs' -> do - { gla_exts <- doptM Opt_GlasgowExts - - -- Check that we don't use kind signatures without Glasgow extensions - ; checkTc gla_exts $ badSigTyDecl tc_name - - -- !!!TODO - -- We need to extend TyCon.TyCon with a new variant representing indexed - -- type constructors (ie, IdxTyCon). We will use them for both indexed - -- data types as well as type functions. In the case of indexed *data* - -- types, they are *abstract*; ie, won't be rewritten. OR do we just want - -- to make another variant of AlgTyCon (after all synonyms are also - -- AlgTyCons...) - -- We need an additional argument to this functions, which determines - -- whether the type constructor is abstract. - ; tycon <- error "TcTyClsDecls.tcKindSigDecl: IdxTyCon not implemented yet." - ; return (ATyCon tycon) - } - ------------------------------------ tcConDecl :: Bool -- True <=> -funbox-strict_fields -> NewOrData -> TyCon -> [TyVar] -> ConDecl Name -> TcM DataCon @@ -887,7 +888,9 @@ checkValidTyCl decl checkValidTyCon :: TyCon -> TcM () checkValidTyCon tc | isSynTyCon tc - = checkValidType syn_ctxt syn_rhs + = case synTyConRhs tc of + OpenSynTyCon _ -> return () + SynonymTyCon ty -> checkValidType syn_ctxt ty | otherwise = -- Check the context on the data decl checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc) `thenM_` @@ -901,7 +904,6 @@ checkValidTyCon tc where syn_ctxt = TySynCtxt name name = tyConName tc - syn_rhs = synTyConRhs tc data_cons = tyConDataCons tc groups = equivClasses cmp_fld (concatMap get_fields data_cons) diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index f45af9e..86d4a2b 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -22,7 +22,7 @@ import RnHsSyn ( extractHsTyNames ) import Type ( predTypeRep, tcView ) import HscTypes ( TyThing(..), ModDetails(..) ) import TyCon ( TyCon, tyConArity, tyConDataCons, tyConTyVars, - synTyConDefn, isSynTyCon, isAlgTyCon, + isSynTyCon, isAlgTyCon, tyConName, isNewTyCon, isProductTyCon, newTyConRhs ) import Class ( classTyCon ) import DataCon ( dataConOrigArgTys ) diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index a382808..a53c9ed 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -169,7 +169,8 @@ import Type ( -- Re-exports pprType, pprParendType, pprTyThingCategory, pprPred, pprTheta, pprThetaArrow, pprClassPred ) -import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, synTyConDefn, tyConUnique ) +import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, isOpenTyCon, + synTyConDefn, tyConUnique ) import DataCon ( DataCon, dataConStupidTheta, dataConResTys ) import Class ( Class ) import Var ( TyVar, Id, isCoVar, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails ) @@ -591,8 +592,9 @@ isTauTy other = False isTauTyCon :: TyCon -> Bool -- Returns False for type synonyms whose expansion is a polytype -isTauTyCon tc | isSynTyCon tc = isTauTy (snd (synTyConDefn tc)) - | otherwise = True +isTauTyCon tc + | isSynTyCon tc && not (isOpenTyCon tc) = isTauTy (snd (synTyConDefn tc)) + | otherwise = True --------------- isBoxyTy :: TcType -> Bool diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 83cd8f2..5ab8458 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -11,10 +11,11 @@ module TyCon( tyConPrimRep, AlgTyConRhs(..), visibleDataCons, + SynTyConRhs(..), isFunTyCon, isUnLiftedTyCon, isProductTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, - isEnumerationTyCon, isGadtSyntaxTyCon, + isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo, isHiBootTyCon, isSuperKindTyCon, @@ -46,7 +47,7 @@ module TyCon( tyConStupidTheta, tyConArity, isClassTyCon, tyConClass_maybe, - synTyConDefn, synTyConRhs, + synTyConDefn, synTyConRhs, synTyConType, synTyConResKind, tyConExtName, -- External name for foreign types maybeTyConSingleCon, @@ -93,10 +94,11 @@ data TyCon tyConKind :: Kind, tyConArity :: Arity, - tyConTyVars :: [TyVar], -- Scopes over (a) the [PredType] in AlgTyConRhs.DataTyCon - -- (b) the cached types in AlgTyConRhs.NewTyCon + tyConTyVars :: [TyVar], -- Scopes over (a) the algTcStupidTheta + -- (b) the cached types in + -- algTyConRhs.NewTyCon -- But not over the data constructors - algTcSelIds :: [Id], -- Its record selectors (empty if none): + algTcSelIds :: [Id], -- Its record selectors (empty if none) algTcGadtSyntax :: Bool, -- True <=> the data type was declared using GADT syntax -- That doesn't mean it's a true GADT; only that the "where" @@ -107,8 +109,8 @@ data TyCon algTcRhs :: AlgTyConRhs, -- Data constructors in here - algTcRec :: RecFlag, -- Tells whether the data type is part of - -- a mutually-recursive group or not + algTcRec :: RecFlag, -- Tells whether the data type is part + -- of a mutually-recursive group or not hasGenerics :: Bool, -- True <=> generic to/from functions are available -- (in the exports of the data type's source module) @@ -135,9 +137,7 @@ data TyCon tyConArity :: Arity, tyConTyVars :: [TyVar], -- Bound tyvars - synTcRhs :: Type -- Right-hand side, mentioning these type vars. - -- Acts as a template for the expansion when - -- the tycon is applied to some types. + synTcRhs :: SynTyConRhs -- Expanded type in here } | PrimTyCon { -- Primitive types; cannot be defined in Haskell @@ -183,6 +183,9 @@ data AlgTyConRhs -- Used when we export a data type abstractly into -- an hi file + | OpenDataTyCon -- data family (further instances can appear + | OpenNewTyCon -- newtype family at any time) + | DataTyCon { data_cons :: [DataCon], -- The constructors; can be empty if the user declares @@ -227,8 +230,16 @@ data AlgTyConRhs visibleDataCons :: AlgTyConRhs -> [DataCon] visibleDataCons AbstractTyCon = [] +visibleDataCons OpenDataTyCon = [] +visibleDataCons OpenNewTyCon = [] visibleDataCons (DataTyCon{ data_cons = cs }) = cs visibleDataCons (NewTyCon{ data_con = c }) = [c] + +data SynTyConRhs + = OpenSynTyCon Kind -- Type family: *result* kind given + | SynonymTyCon Type -- Mentioning head type vars. Acts as a template for + -- the expansion when the tycon is applied to some + -- types. \end{code} Note [Newtype coercions] @@ -507,7 +518,9 @@ isDataTyCon :: TyCon -> Bool -- unboxed tuples isDataTyCon tc@(AlgTyCon {algTcRhs = rhs}) = case rhs of + OpenDataTyCon -> True DataTyCon {} -> True + OpenNewTyCon -> False NewTyCon {} -> False AbstractTyCon -> pprPanic "isDataTyCon" (ppr tc) @@ -547,6 +560,12 @@ isEnumerationTyCon :: TyCon -> Bool isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon { is_enum = res }}) = res isEnumerationTyCon other = False +isOpenTyCon :: TyCon -> Bool +isOpenTyCon (SynTyCon {synTcRhs = OpenSynTyCon _}) = True +isOpenTyCon (AlgTyCon {algTcRhs = OpenDataTyCon }) = True +isOpenTyCon (AlgTyCon {algTcRhs = OpenNewTyCon }) = True +isOpenTyCon _ = False + isTupleTyCon :: TyCon -> Bool -- The unit tycon didn't used to be classed as a tuple tycon -- but I thought that was silly so I've undone it @@ -610,7 +629,8 @@ tcExpandTyCon_maybe, coreExpandTyCon_maybe [Type]) -- Leftover args -- For the *typechecker* view, we expand synonyms only -tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, synTcRhs = rhs }) tys +tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, + synTcRhs = SynonymTyCon rhs }) tys = expand tvs rhs tys tcExpandTyCon_maybe other_tycon tys = Nothing @@ -701,11 +721,22 @@ tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) \begin{code} synTyConDefn :: TyCon -> ([TyVar], Type) -synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = ty}) = (tyvars,ty) +synTyConDefn (SynTyCon {tyConTyVars = tyvars, synTcRhs = SynonymTyCon ty}) + = (tyvars, ty) synTyConDefn tycon = pprPanic "getSynTyConDefn" (ppr tycon) -synTyConRhs :: TyCon -> Type -synTyConRhs tc = synTcRhs tc +synTyConRhs :: TyCon -> SynTyConRhs +synTyConRhs (SynTyCon {synTcRhs = rhs}) = rhs +synTyConRhs tc = pprPanic "synTyConRhs" (ppr tc) + +synTyConType :: TyCon -> Type +synTyConType tc = case synTcRhs tc of + SynonymTyCon t -> t + _ -> pprPanic "synTyConType" (ppr tc) + +synTyConResKind :: TyCon -> Kind +synTyConResKind (SynTyCon {synTcRhs = OpenSynTyCon kind}) = kind +synTyConResKind tycon = pprPanic "synTyConResKind" (ppr tycon) \end{code} \begin{code} diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index 2aa31eb..a7aeeec 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -12,7 +12,7 @@ module Type ( -- Kinds Kind, SimpleKind, KindVar, - kindFunResult, splitKindFunTys, + kindFunResult, splitKindFunTys, splitKindFunTysN, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, argTypeKindTyCon, ubxTupleKindTyCon, @@ -1371,6 +1371,9 @@ kindFunResult k = funResultTy k splitKindFunTys :: Kind -> ([Kind],Kind) splitKindFunTys k = splitFunTys k +splitKindFunTysN :: Int -> Kind -> ([Kind],Kind) +splitKindFunTysN k = splitFunTysN k + isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey