diff options
| author | Trevor Elliott <trevor@galois.com> | 2013-09-08 16:46:17 -0700 |
|---|---|---|
| committer | Trevor Elliott <trevor@galois.com> | 2013-09-08 16:46:17 -0700 |
| commit | 86bf4164c30e210aa280610ec719d01e62cc95a4 (patch) | |
| tree | 04bb65ac37c070628858a1b181925401d7dececd | |
| parent | c798a8c6c66d826efdc0201fa56d45337eecc2af (diff) | |
| download | haskell-86bf4164c30e210aa280610ec719d01e62cc95a4.tar.gz | |
Squashed commit of the following:
commit 6549c3e569d0e0c3714814860201924432da2435
Author: Trevor Elliott <trevor@galois.com>
Date: Sun Sep 8 16:43:42 2013 -0700
Document `data kind` syntax
commit 81c6d7b884e819cf0b0569cef23b67bb5aff8944
Merge: 6c3f34c c798a8c
Author: Trevor Elliott <trevor@galois.com>
Date: Sun Sep 8 11:40:47 2013 -0700
Merge remote-tracking branch 'head/master' into data-kind-syntax-v2
commit 6c3f34c80bd8b17920a956e194ec29d1affbd776
Author: Trevor Elliott <awesomelyawesome@gmail.com>
Date: Wed Aug 28 02:21:07 2013 -0400
Merge with the roles changes
There a bunch of spots where the roles haven't been properly integrated with,
so this patch should get some review.
commit 6bb530f50f655e74fb4e337311699eee46b519b7
Merge: 7d27880 4b5238a
Author: Trevor Elliott <awesomelyawesome@gmail.com>
Date: Tue Aug 27 02:35:55 2013 -0400
Merge remote-tracking branch 'head/master' into data-kind-syntax-v2
Conflicts:
compiler/basicTypes/DataCon.lhs
compiler/iface/IfaceSyn.lhs
compiler/main/PprTyThing.hs
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/typecheck/TcTyDecls.lhs
compiler/types/TyCon.lhs
commit 7d2788021dab549ffd888deb9f28c8e7eab0d4ba
Author: Trevor Elliott <trevor@galois.com>
Date: Mon Jul 29 09:05:38 2013 -0700
Migrate through some lost instances
commit 13e1f41ec9252fd9d547d8e4b9fb04ffaf43c105
Merge: e051060 9e185cc
Author: Trevor Elliott <awesomelyawesome@gmail.com>
Date: Sun Jul 28 14:28:05 2013 -0400
Merge remote-tracking branch 'origin/master' into data-kind-syntax-v2
Moved Binary instances for data-kind related types to IfaceSyn
commit e051060bbef4d359f2b1caa1c6135b23df17ffe7
Merge: 08d7c2f 2f99cdb
Author: Trevor Elliott <awesomelyawesome@gmail.com>
Date: Wed Jul 17 01:58:16 2013 -0400
Merge remote-tracking branch 'origin/master' into data-kind-syntax-v2
commit 08d7c2fca10a8c89b6fd638536a28972753ae360
Author: Trevor Elliott <awesomelyawesome@gmail.com>
Date: Mon Jul 1 21:56:48 2013 -0400
Fix some bugs from the merge with master
* Figure out what the right choice for the kind checking strategy of kind decls
should be
commit 12f055d23a1b5c0a74d2db0784b779b605f3888f
Merge: f0adbdc e56b9d5
Author: Trevor Elliott <awesomelyawesome@gmail.com>
Date: Mon Jul 1 21:12:47 2013 -0400
Merge remote-tracking branch 'origin/master' into data-kind-syntax-v2
Conflicts:
compiler/typecheck/TcTyClsDecls.lhs
commit f0adbdc29fefc54675f0960e3178f3b079058eea
Author: Trevor Elliott <awesomelyawesome@gmail.com>
Date: Sun Jun 23 15:53:06 2013 -0400
Swap the names for PromotionFlavor and PromotionInfo
commit e177270dc002f45286a9b644935ea339d8a6c8d3
Merge: 16df4be 3660ef9
Author: Trevor Elliott <awesomelyawesome@gmail.com>
Date: Sat Jun 22 04:00:15 2013 -0400
Merge remote-tracking branch 'origin/master' into data-kind-syntax-v2
commit 16df4beac24065d3075a65b26add543452d1f2b2
Merge: b021b30 569b265
Author: Trevor Elliott <awesomelyawesome@gmail.com>
Date: Sat Jun 22 02:41:14 2013 -0400
merge with master
commit b021b30f66fdb66965f6c57fb0969317c9aeb9e3
Author: Trevor Elliott <trevor@galois.com>
Date: Thu Jun 20 19:39:20 2013 -0700
Start reworking comments
commit b765370181571c1922b508f8dd17648a090ac248
Merge: d1ac794 e4fc6fd
Author: Trevor Elliott <trevor@galois.com>
Date: Thu Jun 20 18:27:43 2013 -0700
Merge branch 'master' into data-kind-syntax-v2
commit d1ac794b5bd06ae04e014cabe4560628b70fcdeb
Merge: 9ad0a3c 73991d6
Author: Trevor Elliott <trevor@galois.com>
Date: Thu Jun 20 18:16:15 2013 -0700
Merge remote-tracking branch 'origin/master' into data-kind-syntax-v2
commit 9ad0a3c57a5b77f5040f1201b2c53a84680c1af2
Author: Trevor Elliott <trevor@galois.com>
Date: Thu Jun 20 18:13:58 2013 -0700
Don't add the promotion tick to data kind constructors
commit 8c37784e31702ecf7d91f2d7cf7dfab675a56927
Merge: 4dff379 db9b631
Author: Trevor Elliott <trevor@galois.com>
Date: Mon Jun 17 10:55:51 2013 -0700
Merge remote-tracking branch 'origin/master' into data-kind-syntax-v2
Conflicts:
compiler/main/PprTyThing.hs
compiler/rename/RnTypes.lhs
compiler/types/TyCon.lhs
commit 4dff3791ac9d1175d26f8c3b44923aefbe6c3f40
Author: Trevor Elliott <trevor@galois.com>
Date: Mon Jun 3 20:45:00 2013 -0700
When parsing interfaces, use forkM while checking type constructors
commit 7903009475b3e89aecc0a8e5d328ea84ea53a39d
Author: Trevor Elliott <trevor@galois.com>
Date: Mon Jun 3 20:06:40 2013 -0700
When parsing data kind declarations, don't change the constructor namespace
commit 78ff545601cedba106eda05a38ce8f24f8480961
Author: Trevor Elliott <trevor@galois.com>
Date: Mon May 27 18:45:52 2013 -0700
Switch from Maybe TyCon to a richer type for promotion
The new type distinguishes the two cases where promotion isn't possible:
1) Promotion isn't possible, as it's disabled by a 'data type' declaration
2) Promotion isn't possible because we don't know how to promote it
commit 0573fd3e8f9822171ddeb0df937e10075b653678
Author: Trevor Elliott <trevor@galois.com>
Date: Mon May 27 17:36:21 2013 -0700
Remove an old TODO
commit e218d5d6848109e9dea129250199115a9db6b1d9
Author: Trevor Elliott <trevor@galois.com>
Date: Mon May 27 17:36:15 2013 -0700
Properly print data kind declarations in ghci
commit 22b011d43f84cb0478eded613344e1dd165664e5
Author: Trevor Elliott <trevor@galois.com>
Date: Thu May 16 18:38:22 2013 -0700
Switch to using the PromotedDataCon for the RHS of a data kind
Something is still wrong here: doing :browse will get a panic for some
reason.
commit 12db8c704765d2775b0299c2e718d015577a6f18
Author: Trevor Elliott <trevor@galois.com>
Date: Sat May 4 19:06:43 2013 -0700
Thread data kind syntax through the interface
Things are not quite right at the moment. The issue is that we can't
distinguish abstract types from types that are constructors in a data kind.
As such, we should introduce a new constructor to TyCon to help
disambiguate these two cases. Also it might be nice to add a new TyCon
for kinds, which would avoid the need for a new RHS in the AlgTyCon case.
commit 73f19612444e2a3b1534ab41f02449c9a5191ccb
Author: Trevor Elliott <trevor@galois.com>
Date: Tue Apr 30 20:30:21 2013 -0700
Handle kind declarations separately
commit 8d3bf040748026829382c5d13421f910b3f9fcf9
Author: Trevor Elliott <trevor@galois.com>
Date: Fri Apr 26 20:40:49 2013 -0700
Partial type-kind checking of `data kind` declarations
commit 2399eb788ed0fe571c22de4f810080a323ddaceb
Author: Trevor Elliott <trevor@galois.com>
Date: Fri Apr 26 18:01:28 2013 -0700
Support empty `data kind` declarations
commit 61a28f2df42b34742219a97a22c029f840fef7f5
Author: Trevor Elliott <trevor@galois.com>
Date: Fri Apr 26 17:34:31 2013 -0700
Rename `data kind` declarations
commit 5d3485a3e3ab7a78f1055b872f78203d5d005b76
Author: Trevor Elliott <trevor@galois.com>
Date: Fri Apr 26 16:53:26 2013 -0700
Fix a typo in a parser comment
commit 7f631cf41a3ca84cd820b292711014b4e806a440
Author: Trevor Elliott <trevor@galois.com>
Date: Fri Apr 26 16:53:00 2013 -0700
Add paring for `data kind` declarations
commit d29733901b2cd195989cdc972ac74c1ed4f19670
Author: Trevor Elliott <trevor@galois.com>
Date: Fri Apr 26 14:31:30 2013 -0700
Rename typeLiteralsBit to dataKindsBit in the lexer
commit ca8ae194826fc47a2ba4f0188d62f5247b0fe631
Author: Trevor Elliott <trevor@galois.com>
Date: Fri Apr 26 14:27:50 2013 -0700
Add a check for -XDataKinds when parsing a `data type` declaration
commit 8588717e8ce224affa584bd1e27aa14e098f5a8f
Author: Trevor Elliott <trevor@galois.com>
Date: Fri Apr 26 14:18:41 2013 -0700
Implement the 'data type' syntax and checking
Add a new form of data declaration where the 'type' modifier can be used
to prevent data promotion. For example
data type T = K
will not yield a promoted kind T, and promoted type K, even though they are
in principle promotable.
26 files changed, 751 insertions, 94 deletions
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 51a096b10f..1c81934408 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -1004,13 +1004,13 @@ buildAlgTyCon :: Name -> ThetaType -- ^ Stupid theta -> AlgTyConRhs -> RecFlag - -> Bool -- ^ True <=> this TyCon is promotable + -> PromotionInfo () -> Bool -- ^ True <=> was declared in GADT syntax -> TyConParent -> TyCon buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs - is_rec is_promotable gadt_syn parent + is_rec prom_flavor gadt_syn parent = tc where kind = mkPiKinds ktvs liftedTypeKind @@ -1018,11 +1018,10 @@ buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs -- tc and mb_promoted_tc are mutually recursive tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta rhs parent is_rec gadt_syn - mb_promoted_tc + promotion_info - mb_promoted_tc - | is_promotable = Just (mkPromotedTyCon tc (promoteKind kind)) - | otherwise = Nothing + promotion_info = + fmap (\ _ -> mkPromotedTyCon tc (promoteKind kind)) prom_flavor \end{code} diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 383b641262..123bfeac07 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -166,6 +166,7 @@ cvtDec (DataD ctxt tc tvs constrs derivs) ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing + , dd_try_promote = True , dd_ctxt = ctxt' , dd_kindSig = Nothing , dd_cons = cons', dd_derivs = derivs' } @@ -177,6 +178,7 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs) ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing + , dd_try_promote = True , dd_ctxt = ctxt' , dd_kindSig = Nothing , dd_cons = [con'], dd_derivs = derivs' } @@ -224,6 +226,7 @@ cvtDec (DataInstD ctxt tc tys constrs derivs) ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing + , dd_try_promote = True , dd_ctxt = ctxt' , dd_kindSig = Nothing , dd_cons = cons', dd_derivs = derivs' } @@ -237,6 +240,7 @@ cvtDec (NewtypeInstD ctxt tc tys constr derivs) ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing + , dd_try_promote = True , dd_ctxt = ctxt' , dd_kindSig = Nothing , dd_cons = [con'], dd_derivs = derivs' } diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index ee4b0fab34..0828c6ec8f 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -16,7 +16,7 @@ module HsDecls ( HsDecl(..), LHsDecl, HsDataDefn(..), -- ** Class or type declarations TyClDecl(..), LTyClDecl, TyClGroup, - isClassDecl, isDataDecl, isSynDecl, tcdName, + isClassDecl, isDataDecl, isKindDecl, isSynDecl, tcdName, isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, isOpenTypeFamilyInfo, isClosedTypeFamilyInfo, tyFamInstDeclName, tyFamInstDeclLName, @@ -50,6 +50,8 @@ module HsDecls ( -- ** Data-constructor declarations ConDecl(..), LConDecl, ResType(..), HsConDeclDetails, hsConDeclArgTys, + TyConDecl(..), LTyConDecl, + HsTyConDeclDetails, -- ** Document comments DocDecl(..), LDocDecl, docDeclDoc, -- ** Deprecations @@ -456,6 +458,12 @@ data TyClDecl name , tcdDataDefn :: HsDataDefn name , tcdFVs :: NameSet } + | -- | @data kind@ declaration + KindDecl { tcdLName :: Located name + , tcdKVars :: [Located name] + , tcdTypeCons :: [LTyConDecl name] + , tcdFvs :: NameSet } + | ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context... tcdLName :: Located name, -- ^ Name of the class tcdTyVars :: LHsTyVarBndrs name, -- ^ Class type variables @@ -497,6 +505,10 @@ isDataDecl :: TyClDecl name -> Bool isDataDecl (DataDecl {}) = True isDataDecl _other = False +isKindDecl :: TyClDecl name -> Bool +isKindDecl (KindDecl {}) = True +isKindDecl _ = False + -- | type or type instance declaration isSynDecl :: TyClDecl name -> Bool isSynDecl (SynDecl {}) = True @@ -566,6 +578,7 @@ tyClDeclTyVars d = tcdTyVars d \begin{code} countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int) -- class, synonym decls, data, newtype, family decls + -- we don't count `data kind` decls here countTyClDecls decls = (count isClassDecl decls, count isSynDecl decls, -- excluding... @@ -596,6 +609,9 @@ instance OutputableBndr name ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdDataDefn = defn }) = pp_data_defn (pp_vanilla_decl_head ltycon tyvars) defn + ppr (KindDecl { tcdLName = lkcon, tcdKVars = kvars, tcdTypeCons = cons }) + = pp_kind_decl lkcon kvars cons + ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, tcdMeths = methods, @@ -660,6 +676,7 @@ pprTyClDeclFlavour (FamDecl {}) = ptext (sLit "family") pprTyClDeclFlavour (SynDecl {}) = ptext (sLit "type") pprTyClDeclFlavour (DataDecl { tcdDataDefn = (HsDataDefn { dd_ND = nd }) }) = ppr nd +pprTyClDeclFlavour (KindDecl {}) = ptext (sLit "data kind") pprTyClDeclFlavour (ForeignType {}) = ptext (sLit "foreign type") \end{code} @@ -682,6 +699,10 @@ data HsDataDefn name -- The payload of a data type defn HsDataDefn { dd_ND :: NewOrData, dd_ctxt :: LHsContext name, -- ^ Context dd_cType :: Maybe CType, + dd_try_promote :: Bool, + -- ^ This boolean determines whether we should try to promote + -- the type. Even if it's True, the type may still not be + -- promotable. dd_kindSig:: Maybe (LHsKind name), -- ^ Optional kind signature. -- @@ -769,6 +790,28 @@ data ConDecl name -- need to report decprecated use } deriving (Data, Typeable) +type LTyConDecl name = Located (TyConDecl name) + +type HsTyConDeclDetails name = HsConDetails (LHsKind name) () + +-- | The type constructor for the right hand side of a @data kind@ declaration. +data TyConDecl name + = TyConDecl + { tycon_name :: Located name -- ^ name of type constructor + , tycon_details :: HsTyConDeclDetails name -- ^ argument kinds + , tycon_doc :: Maybe LHsDocString -- ^ optional documentation + } deriving (Data, Typeable) + +instance OutputableBndr name => Outputable (TyConDecl name) where + ppr TyConDecl { tycon_name = name, tycon_details = details + , tycon_doc = doc } + = sep [ppr_mbDoc doc, ppr_details] + where + ppr_details = case details of + InfixCon l r -> hsep [ppr l, pprInfixOcc (unLoc name), ppr r] + PrefixCon args -> hsep (pprPrefixOcc (unLoc name) : map (pprParendHsType . unLoc) args) + RecCon _ -> panic "Outputtable (TyConDecl name)" "unexpected record constructor" + type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name] hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name] @@ -790,20 +833,35 @@ instance Outputable ty => Outputable (ResType ty) where \begin{code} + +pp_kind_decl :: OutputableBndr name + => Located name -> [Located name] -> [LTyConDecl name] -> SDoc +pp_kind_decl kname kvars cons + = ptext (sLit "data kind") <+> ppr (unLoc kname) + <+> hsep (map (ppr . unLoc) kvars) <+> rhs + + where + rhs | null cons = empty + | otherwise = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cons)) + pp_data_defn :: OutputableBndr name => (HsContext name -> SDoc) -- Printing the header -> HsDataDefn name -> SDoc pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context + , dd_try_promote = try_promote , dd_kindSig = mb_sig , dd_cons = condecls, dd_derivs = derivings }) | null condecls - = ppr new_or_data <+> pp_hdr context <+> pp_sig + = ppr new_or_data <+> pp_prom <+> pp_hdr context <+> pp_sig | otherwise - = hang (ppr new_or_data <+> pp_hdr context <+> pp_sig) + = hang (ppr new_or_data <+> pp_prom <+> pp_hdr context <+> pp_sig) 2 (pp_condecls condecls $$ pp_derivings) where + pp_prom | try_promote = empty + | otherwise = ptext (sLit "type") + pp_sig = case mb_sig of Nothing -> empty Just kind -> dcolon <+> ppr kind diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 267b2cac0e..accae0dd06 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -655,6 +655,9 @@ hsTyClDeclBinders (ClassDecl { tcdLName = cls_name, tcdSigs = sigs hsTyClDeclBinders (DataDecl { tcdLName = name, tcdDataDefn = defn }) = name : hsDataDefnBinders defn +hsTyClDeclBinders (KindDecl { tcdLName = name, tcdTypeCons = cons }) + = name : map (tycon_name . unLoc) cons + ------------------- hsInstDeclBinders :: Eq name => InstDecl name -> [Located name] hsInstDeclBinders (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }) diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index f6e68e2836..b12906b3b4 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -16,6 +16,7 @@ module IfaceSyn ( IfaceDecl(..), IfaceSynTyConRhs(..), IfaceClassOp(..), IfaceAT(..), IfaceConDecl(..), IfaceConDecls(..), + IfaceTyConDecl(..), IfaceExpr(..), IfaceAlt, IfaceLetBndr(..), IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), @@ -36,6 +37,7 @@ module IfaceSyn ( #include "HsVersions.h" +import TyCon( PromotionInfo(..) ) import IfaceType import PprCore() -- Printing DFunArgs import Demand @@ -76,6 +78,12 @@ data IfaceDecl ifIdDetails :: IfaceIdDetails, ifIdInfo :: IfaceIdInfo } + | IfaceDataKind { ifName :: OccName, -- Kind constructor + ifRec :: RecFlag, -- Recursive or not? + ifKVars :: [IfaceTvBndr], -- Kind parameters + ifTyCons :: [IfaceTyConDecl] -- Type constructors of this kind + } + | IfaceData { ifName :: OccName, -- Type constructor ifCType :: Maybe CType, -- C type for CAPI FFI ifTyVars :: [IfaceTvBndr], -- Type variables @@ -83,7 +91,7 @@ data IfaceDecl ifCtxt :: IfaceContext, -- The "stupid theta" ifCons :: IfaceConDecls, -- Includes new/data/data family info ifRec :: RecFlag, -- Recursive or not? - ifPromotable :: Bool, -- Promotable to kind level? + ifPromotable :: PromotionInfo (),-- Promotable to kind level? ifGadtSyntax :: Bool, -- True <=> declared using -- GADT syntax ifAxiom :: Maybe IfExtName -- The axiom, for a newtype, @@ -173,6 +181,14 @@ instance Binary IfaceDecl where put_ bh a3 put_ bh a4 + put_ bh (IfaceDataKind a1 a2 a3 a4) = do + putByte bh 6 + put_ bh (occNameFS a1) + put_ bh a2 + put_ bh a3 + put_ bh a4 + + get bh = do h <- getByte bh case h of @@ -212,12 +228,32 @@ instance Binary IfaceDecl where a8 <- get bh occ <- return $! mkOccNameFS clsName a2 return (IfaceClass a1 occ a3 a4 a5 a6 a7 a8) - _ -> do a1 <- get bh + 5 -> do a1 <- get bh a2 <- get bh a3 <- get bh a4 <- get bh occ <- return $! mkOccNameFS tcName a1 return (IfaceAxiom occ a2 a3 a4) + 6 -> do a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + occ <- return $! mkOccNameFS tcName a1 + return (IfaceDataKind occ a2 a3 a4) + _ -> error ("Binary.get(TyClDecl): Unknown tag " ++ show h) + +instance Binary (PromotionInfo ()) where + put_ bh p = case p of + NeverPromote -> putByte bh 0x0 + NotPromotable -> putByte bh 0x1 + Promotable () -> putByte bh 0x2 + get bh = do + tag <- getByte bh + case tag of + 0x0 -> return NeverPromote + 0x1 -> return NotPromotable + 0x2 -> return (Promotable ()) + _ -> error ("Binary.get(Promotable ()): Unknown tag " ++ show tag) data IfaceSynTyConRhs = IfaceOpenSynFamilyTyCon @@ -398,6 +434,22 @@ instance Binary IfaceBang where 2 -> do return IfUnpack _ -> do { a <- get bh; return (IfUnpackCo a) } +data IfaceTyConDecl + = IfTyCon { + ifTyConOcc :: OccName, -- constructor name + ifTyConArgKs :: [IfaceKind] -- constructor argument kinds + } + +instance Binary IfaceTyConDecl where + put_ bh (IfTyCon a1 a2) = do + put_ bh (occNameFS a1) + put_ bh a2 + get bh = do + a1 <- get bh + a2 <- get bh + occ <- return $! mkOccNameFS tcName a1 + return (IfTyCon occ a2) + data IfaceClsInst = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst @@ -951,6 +1003,9 @@ ifaceDeclImplicitBndrs (IfaceData {ifName = _tc_occ, has_wrapper = ifConWrapper con_decl -- This is the reason for -- having the ifConWrapper field! +ifaceDeclImplicitBndrs IfaceDataKind { ifTyCons = cons } + = map ifTyConOcc cons + ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ, ifSigs = sigs, ifATs = ats }) = -- (possibly) newtype coercion @@ -1020,6 +1075,15 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifRoles = roles, = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars roles) 4 (dcolon <+> ppr kind) +pprIfaceDecl IfaceDataKind {ifName = kcon, ifKVars = kvars, + ifTyCons = tycons } + -- XXX what should the roles argument be here? + = hang (ptext (sLit "data kind") <+> pprIfaceDeclHead [] kcon kvars []) 4 $ + if null tycons + then empty + else equals <+> sep (punctuate (ptext (sLit " |")) (map pprIfaceTyConDecl tycons)) + + -- this case handles both abstract and instantiated closed family tycons pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifRoles = roles, ifSynRhs = _closedSynFamilyTyCon, ifSynKind = kind }) @@ -1037,8 +1101,11 @@ pprIfaceDecl (IfaceData {ifName = tycon, ifCType = cType, , pp_condecls tycon condecls , pprAxiom mbAxiom]) where - pp_prom | is_prom = ptext (sLit "Promotable") - | otherwise = ptext (sLit "Not promotable") + pp_prom = case is_prom of + NeverPromote -> ptext (sLit "Never promotable") + NotPromotable -> ptext (sLit "Not promotable") + Promotable () -> ptext (sLit "Promotable") + pp_nd = case condecls of IfAbstractTyCon dis -> ptext (sLit "abstract") <> parens (ppr dis) IfDataFamTyCon -> ptext (sLit "data family") @@ -1086,6 +1153,10 @@ pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |")) (map (pprIfaceConDecl tc) cs)) +pprIfaceTyConDecl :: IfaceTyConDecl -> SDoc +pprIfaceTyConDecl IfTyCon { ifTyConOcc = name, ifTyConArgKs = kinds } + = hsep (parenSymOcc name (ppr name) : map pprParendIfaceType kinds) + mkIfaceEqPred :: IfaceType -> IfaceType -> IfacePredType -- IA0_NOTE: This is wrong, but only used for pretty-printing. mkIfaceEqPred ty1 ty2 = IfaceTyConApp (IfaceTc eqTyConName) [ty1, ty2] @@ -1306,6 +1377,9 @@ freeNamesIfDecl d@IfaceData{} = maybe emptyNameSet unitNameSet (ifAxiom d) &&& freeNamesIfContext (ifCtxt d) &&& freeNamesIfConDecls (ifCons d) +freeNamesIfDecl d@IfaceDataKind{} = + freeNamesIfTvBndrs (ifKVars d) &&& + fnList freeNamesIfTyConDecl (ifTyCons d) freeNamesIfDecl d@IfaceSyn{} = freeNamesIfTvBndrs (ifTyVars d) &&& freeNamesIfSynRhs (ifSynRhs d) &&& @@ -1355,6 +1429,10 @@ freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c freeNamesIfConDecls _ = emptyNameSet +freeNamesIfTyConDecl :: IfaceTyConDecl -> NameSet +freeNamesIfTyConDecl c = + fnList freeNamesIfKind (ifTyConArgKs c) + freeNamesIfConDecl :: IfaceConDecl -> NameSet freeNamesIfConDecl c = freeNamesIfTvBndrs (ifConUnivTvs c) &&& diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 44f99d520e..6764c916eb 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1499,6 +1499,12 @@ tyConToIfaceDecl env tycon ifSynRhs = to_ifsyn_rhs syn_rhs, ifSynKind = tidyToIfaceType env1 (synTyConResKind tycon) } + | DataKindTyCon cons <- algTyConRhs tycon + = IfaceDataKind { ifName = getOccName tycon + , ifRec = boolToRecFlag (isRecursiveTyCon tycon) + , ifKVars = toIfaceTvBndrs tyvars + , ifTyCons = map ifaceTyConDecl cons } + | isAlgTyCon tycon = IfaceData { ifName = getOccName tycon, ifCType = tyConCType tycon, @@ -1508,7 +1514,7 @@ tyConToIfaceDecl env tycon ifCons = ifaceConDecls (algTyConRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifPromotable = isJust (promotableTyCon_maybe tycon), + ifPromotable = fmap (\_ -> ()) (promotableTyConInfo tycon), ifAxiom = fmap coAxiomName (tyConFamilyCoercion_maybe tycon) } | isForeignTyCon tycon @@ -1534,6 +1540,7 @@ tyConToIfaceDecl env tycon -- Furthermore, tyThingToIfaceDecl is also used -- in TcRnDriver for GHCi, when browsing a module, in which case the -- AbstractTyCon case is perfectly sensible. + ifaceConDecls DataKindTyCon{} = pprPanic "ifaceConDecls" (ptext (sLit "unexpected 'data kind' rhs")) ifaceConDecl data_con = IfCon { ifConOcc = getOccName (dataConName data_con), @@ -1557,6 +1564,12 @@ tyConToIfaceDecl env tycon to_eq_spec spec = [ (getOccName (tidyTyVar env2 tv), tidyToIfaceType env2 ty) | (tv,ty) <- spec] + ifaceTyConDecl ty_con + = IfTyCon { ifTyConOcc = getOccName (tyConName ty_con), + ifTyConArgKs = map (tidyToIfaceType emptyTidyEnv) args } + where + (args,_) = splitFunTys (tyConKind ty_con) + toIfaceBang :: TidyEnv -> HsBang -> IfaceBang toIfaceBang _ HsNoBang = IfNoBang toIfaceBang _ (HsUnpack Nothing) = IfUnpack diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 2d2e867390..d6b6a55abe 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -434,6 +434,30 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ; info <- tcIdInfo ignore_prags name ty info ; return (AnId (mkGlobalId details name ty info)) } +tc_iface_decl _ _ IfaceDataKind {ifName = occ_name, + ifRec = is_rec, + ifKVars = kvs, + ifTyCons = cons} + = bindIfaceTyVars_AT kvs $ \ kvs' -> + do kc_name <- lookupIfaceTop occ_name + kcon <- fixM $ \ kcon -> + do let kind = mkTyConApp kcon (mkTyVarTys kvs') + cons <- mapM (tcIfaceTyConDecl kind kcon) cons + let sKind = mkFunTys (map Var.tyVarKind kvs') superKind + return $ mkAlgTyCon + kc_name + sKind + kvs' + [] + Nothing + [] + (DataKindTyCon cons) + NoParentTyCon + is_rec + False + NotPromotable + return (ATyCon kcon) + tc_iface_decl parent _ (IfaceData {ifName = occ_name, ifCType = cType, ifTyVars = tv_bndrs, @@ -643,6 +667,16 @@ tcIfaceDataCons tycon_name tycon _ if_cons tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co ; return (HsUnpack (Just co)) } +tcIfaceTyConDecl :: Kind -> KCon -> IfaceTyConDecl -> IfL TyCon +tcIfaceTyConDecl kind kcon IfTyCon { ifTyConOcc = occ_name, ifTyConArgKs = args } + = do name <- lookupIfaceTop occ_name + -- See the comment in tc_con_decl of tcIfaceDataCons for why forkM + kinds <- forkM pp_name (mapM tcIfaceKind args) + return (mkDataKindTyCon kcon name (mkFunTys kinds kind)) + where + pp_name = ptext (sLit "Type constructor") <+> ppr occ_name + + tcIfaceEqSpec :: [(OccName, IfaceType)] -> IfL [(TyVar, Type)] tcIfaceEqSpec spec = mapM do_item spec diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 33dbba2c21..0808d7229e 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -1376,9 +1376,12 @@ implicitTyConThings tc -- for each data constructor in order, -- the contructor, worker, and (possibly) wrapper - concatMap (extras_plus . ADataCon) (tyConDataCons tc) + concatMap (extras_plus . ADataCon) (tyConDataCons tc) ++ -- NB. record selectors are *not* implicit, they have fully-fledged -- bindings that pass through the compilation pipeline as normal. + + -- type constructors, if this is a 'data kind' declaration. + map ATyCon (kConTypeCons tc) where class_stuff = case tyConClass_maybe tc of Nothing -> [] @@ -1414,9 +1417,13 @@ isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax -- might have a parent. tyThingParent_maybe :: TyThing -> Maybe TyThing tyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc)) -tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of - Just cls -> Just (ATyCon (classTyCon cls)) - Nothing -> Nothing +tyThingParent_maybe (ATyCon tc) + | Just cls <- tyConAssoc_maybe tc + = Just (ATyCon (classTyCon cls)) + | Just s <- tyConDataKind_maybe tc + = Just (ATyCon s) + | otherwise + = Nothing tyThingParent_maybe (AnId id) = case idDetails id of RecSelId { sel_tycon = tc } -> Just (ATyCon tc) ClassOpId cls -> Just (ATyCon (classTyCon cls)) diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index b95c69902a..dddfe10de1 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -40,6 +40,7 @@ import VarEnv( emptyTidyEnv ) import StaticFlags( opt_PprStyle_Debug ) import Outputable import FastString +import Data.Maybe (isJust) -- ----------------------------------------------------------------------------- -- Pretty-printing entities that we get from the GHC API @@ -116,7 +117,7 @@ pprTyConHdr pefas tyCon | Just cls <- tyConClass_maybe tyCon = pprClassHdr pefas cls | otherwise - = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> pprTvBndrs vars + = ptext keyword <+> opt_modifier <+> opt_stupid <+> ppr_bndr tyCon <+> pprTvBndrs vars where vars | GHC.isPrimTyCon tyCon || GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars @@ -126,8 +127,10 @@ pprTyConHdr pefas tyCon | GHC.isNewTyCon tyCon = sLit "newtype" | otherwise = sLit "data" - opt_family + opt_modifier | GHC.isFamilyTyCon tyCon = ptext (sLit "family") + | isJust (kConTypeCons_maybe tyCon) = ptext (sLit "kind") + | NeverPromote <- promotableTyConInfo tyCon = ptext (sLit "type") | otherwise = empty opt_stupid -- The "stupid theta" part of the declaration @@ -187,14 +190,33 @@ pprTyCon pefas ss tyCon -- e.g. type T = forall a. a->a | Just cls <- GHC.tyConClass_maybe tyCon = pprClass pefas ss cls + | Just s <- tyConDataKind_maybe tyCon + = pprTyCon pefas ss s + | Just tys <- kConTypeCons_maybe tyCon + = pprDataKind pefas ss tyCon tys | otherwise = pprAlgTyCon pefas ss tyCon - where closed_family_header = pprTyConHdr pefas tyCon <+> dcolon <+> pprTypeForUser pefas (GHC.synTyConResKind tyCon) <+> ptext (sLit "where") +pprDataKind :: PrintExplicitForalls -> ShowSub -> TyCon -> [TyCon] -> SDoc +pprDataKind pefas ss kcon tys = + hang (pprTyConHdr pefas kcon) + 2 (add_bars (ppr_trim (map show_con tys))) + where + ok_con tyc = showSub ss tyc + show_con tyc + | ok_con tyc = Just (pprTyConDecl tyc) + | otherwise = Nothing + +pprTyConDecl :: TyCon -> SDoc +pprTyConDecl tyc = ppr_bndr tyc <+> sep (map GHC.pprParendType fs) + where + (_vars, kind) = GHC.splitForAllTys (tyConKind tyc) + (fs, _res) = tcSplitFunTys kind + pprAlgTyCon :: PrintExplicitForalls -> ShowSub -> TyCon -> SDoc pprAlgTyCon pefas ss tyCon | gadt = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$ diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs index bf22cd77c1..0beaf6c7ef 100644 --- a/compiler/parser/HaddockUtils.hs +++ b/compiler/parser/HaddockUtils.hs @@ -28,3 +28,16 @@ addConDocs (x:xs) doc = x : addConDocs xs doc addConDocFirst :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a] addConDocFirst [] _ = [] addConDocFirst (x:xs) doc = addConDoc x doc : xs + +addTyConDoc :: LTyConDecl a -> Maybe LHsDocString -> LTyConDecl a +addTyConDoc decl Nothing = decl +addTyConDoc (L p c) doc = L p ( c { tycon_doc = tycon_doc c `mplus` doc } ) + +addTyConDocs :: [LTyConDecl a] -> Maybe LHsDocString -> [LTyConDecl a] +addTyConDocs [] _ = [] +addTyConDocs [x] doc = [addTyConDoc x doc] +addTyConDocs (x:xs) doc = x : addTyConDocs xs doc + +addTyConDocFirst :: [LTyConDecl a] -> Maybe LHsDocString -> [LTyConDecl a] +addTyConDocFirst [] _ = [] +addTyConDocFirst (x:xs) doc = addTyConDoc x doc : xs diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 12389e7f17..f7288b3f50 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -56,7 +56,7 @@ module Lexer ( getLexState, popLexState, pushLexState, extension, bangPatEnabled, datatypeContextsEnabled, traditionalRecordSyntaxEnabled, - typeLiteralsEnabled, + dataKindsEnabled, explicitForallEnabled, inRulePrag, explicitNamespacesEnabled, sccProfilingOn, hpcEnabled, @@ -478,6 +478,7 @@ data Token | ITgroup | ITby | ITusing + | ITkind | ITnominal | ITrepresentational | ITphantom @@ -656,6 +657,7 @@ reservedWordsFM = listToUFM $ ( "group", ITgroup, bit transformComprehensionsBit), ( "by", ITby, bit transformComprehensionsBit), ( "using", ITusing, bit transformComprehensionsBit), + ( "kind", ITkind, bit dataKindsBit), ( "foreign", ITforeign, bit ffiBit), ( "export", ITexport, bit ffiBit), @@ -1894,8 +1896,8 @@ safeHaskellBit :: Int safeHaskellBit = 26 traditionalRecordSyntaxBit :: Int traditionalRecordSyntaxBit = 27 -typeLiteralsBit :: Int -typeLiteralsBit = 28 +dataKindsBit :: Int +dataKindsBit = 28 explicitNamespacesBit :: Int explicitNamespacesBit = 29 lambdaCaseBit :: Int @@ -1950,8 +1952,8 @@ sccProfilingOn :: Int -> Bool sccProfilingOn flags = testBit flags sccProfilingOnBit traditionalRecordSyntaxEnabled :: Int -> Bool traditionalRecordSyntaxEnabled flags = testBit flags traditionalRecordSyntaxBit -typeLiteralsEnabled :: Int -> Bool -typeLiteralsEnabled flags = testBit flags typeLiteralsBit +dataKindsEnabled :: Int -> Bool +dataKindsEnabled flags = testBit flags dataKindsBit explicitNamespacesEnabled :: Int -> Bool explicitNamespacesEnabled flags = testBit flags explicitNamespacesBit @@ -2019,7 +2021,7 @@ mkPState flags buf loc = .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags .|. safeHaskellBit `setBitIf` safeImportsOn flags .|. traditionalRecordSyntaxBit `setBitIf` xopt Opt_TraditionalRecordSyntax flags - .|. typeLiteralsBit `setBitIf` xopt Opt_DataKinds flags + .|. dataKindsBit `setBitIf` xopt Opt_DataKinds flags .|. explicitNamespacesBit `setBitIf` xopt Opt_ExplicitNamespaces flags .|. lambdaCaseBit `setBitIf` xopt Opt_LambdaCase flags .|. negativeLiteralsBit `setBitIf` xopt Opt_NegativeLiterals flags diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index b18d0d35c6..1ad7036e6b 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -257,6 +257,7 @@ incorrect. 'group' { L _ ITgroup } -- for list transform extension 'by' { L _ ITby } -- for list transform extension 'using' { L _ ITusing } -- for list transform extension + 'kind' { L _ ITkind } 'N' { L _ ITnominal } -- Nominal role 'R' { L _ ITrepresentational } -- Representational role 'P' { L _ ITphantom } -- Phantom role @@ -637,20 +638,26 @@ ty_decl :: { LTyClDecl RdrName } {% do { L loc decl <- mkFamDecl (comb4 $1 $3 $4 $5) (unLoc $5) $3 (unLoc $4) ; return (L loc (FamDecl decl)) } } + | 'data' 'kind' type kconstrs + {% mkTyDataKind (comb3 $1 $3 $4) $3 (unLoc $4) } + + | 'data' 'kind' type + {% mkTyDataKind (comb2 $1 $3) $3 [] } + -- ordinary data type or newtype declaration - | data_or_newtype capi_ctype tycl_hdr constrs deriving - {% mkTyData (comb4 $1 $3 $4 $5) (unLoc $1) $2 $3 - Nothing (reverse (unLoc $4)) (unLoc $5) } + | data_or_newtype promotable capi_ctype tycl_hdr constrs deriving + {% mkTyData (comb4 $1 $4 $5 $6) (unLoc $1) $2 $3 $4 + Nothing (reverse (unLoc $5)) (unLoc $6) } -- 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 + | data_or_newtype promotable capi_ctype tycl_hdr opt_kind_sig gadt_constrlist deriving - {% mkTyData (comb4 $1 $3 $5 $6) (unLoc $1) $2 $3 - (unLoc $4) (unLoc $5) (unLoc $6) } - -- We need the location on tycl_hdr in case + {% mkTyData (comb4 $1 $4 $6 $7) (unLoc $1) $2 $3 $4 + (unLoc $5) (unLoc $6) (unLoc $7) } + -- We need the location on tycl_hdr in case -- constrs and deriving are both empty -- data/newtype family @@ -658,6 +665,10 @@ ty_decl :: { LTyClDecl RdrName } {% do { L loc decl <- mkFamDecl (comb3 $1 $2 $4) DataFamily $3 (unLoc $4) ; return (L loc (FamDecl decl)) } } +promotable :: { Bool } + : 'type' { False } -- not promotable + | { True } -- promotable + inst_decl :: { LInstDecl RdrName } : 'instance' inst_type where_inst { let (binds, sigs, _, ats, adts, _) = cvBindsAndSigs (unLoc $3) in @@ -1289,10 +1300,10 @@ constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) } -- C t1 t2 -- as a btype (treating C as a type constructor) and then convert C to be -- a data constructor. Reason: it might continue like this: --- C t1 t2 %: D Int +-- C t1 t2 :% D Int -- in which case C really would be a type constructor. We can't resolve this -- ambiguity till we come across the constructor oprerator :% (or not, more usually) - : btype {% splitCon $1 >>= return.LL } + : btype {% splitCon True $1 >>= return.LL } | btype conop btype { LL ($2, InfixCon $1 $3) } fielddecls :: { [ConDeclField RdrName] } @@ -1322,6 +1333,34 @@ deriving :: { Located (Maybe [LHsType RdrName]) } -- Glasgow extension: allow partial -- applications in derivings +kconstrs :: { Located [LTyConDecl RdrName] } + : maybe_docnext '=' kconstrs1 + { L (comb2 $2 $3) (addTyConDocs (reverse (unLoc $3)) $1) } + +kconstrs1 :: { Located [LTyConDecl RdrName] } + : kconstrs1 maybe_docnext '|' maybe_docprev kconstr + { LL (addTyConDoc $5 $2 : addTyConDocFirst (unLoc $1) $4) } + | kconstr + { L1 [$1] } + +kconstr :: { LTyConDecl RdrName } + : maybe_docnext kconstr_stuff maybe_docprev + { let (con,details) = unLoc $2 in + addTyConDoc (L (getLoc $2) (mkTyConDecl con details)) ($1 `mplus` $3) + } + +kconstr_stuff :: { Located (Located RdrName, HsTyConDeclDetails RdrName) } + -- we reuse splitCon here because types and kinds are represented in + -- the same way, except that we don't change the constructor + -- namespace. + : bkind {% splitCon False $1 >>= \ (con,details) -> + toTyConDetails (getLoc $1) details >>= \ kdetails -> + return (LL (con,kdetails)) + } + | bkind conop bkind { LL ($2, InfixCon $1 $3) } + + + ----------------------------------------------------------------------------- -- Value definitions @@ -2012,6 +2051,7 @@ varid :: { Located RdrName } | 'interruptible' { L1 $! mkUnqual varName (fsLit "interruptible") } | 'forall' { L1 $! mkUnqual varName (fsLit "forall") } | 'family' { L1 $! mkUnqual varName (fsLit "family") } + | 'kind' { L1 $! mkUnqual varName (fsLit "kind") } qvarsym :: { Located RdrName } : varsym { $1 } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index fb5f43f5e9..2310ca4815 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -10,10 +10,11 @@ module RdrHsSyn ( mkHsDo, mkHsSplice, mkTopSpliceDecl, mkClassDecl, mkTyData, mkFamInstData, + mkTyDataKind, mkTySynonym, mkTyFamInstEqn, mkTyFamInst, mkFamDecl, - splitCon, mkInlinePragma, + splitCon, mkInlinePragma, toTyConDetails, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp mkTyLit, @@ -29,6 +30,7 @@ module RdrHsSyn ( mkExtName, -- RdrName -> CLabelString mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName mkSimpleConDecl, + mkTyConDecl, mkDeprecatedGadtRecordDecl, -- Bunch of functions in the parser monad for @@ -123,20 +125,60 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls mkTyData :: SrcSpan -> NewOrData + -> Bool -> Maybe CType -> Located (Maybe (LHsContext RdrName), LHsType RdrName) -> Maybe (LHsKind RdrName) -> [LConDecl RdrName] -> Maybe [LHsType RdrName] -> P (LTyClDecl RdrName) -mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv +mkTyData loc new_or_data promotable cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams) <- checkTyClHdr tycl_hdr ; tyvars <- checkTyVars tycl_hdr tparams - ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + + -- promotion has been explicitly disabled, make sure that -XDataKinds + -- is present + ; when (not promotable) $ do + pstate <- getPState + let enabled = xopt Opt_DataKinds (dflags pstate) + unless enabled (parseErrorSDoc loc (text "Illegal `data type` declaration (use -XDataKinds to enable)")) + ; defn <- mkDataDefn new_or_data promotable cType mcxt ksig data_cons maybe_deriv ; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = placeHolderNames })) } +mkTyDataKind :: SrcSpan + -> LHsType RdrName + -> [LTyConDecl RdrName] + -> P (LTyClDecl RdrName) +mkTyDataKind loc k_hdr ty_cons + = do { (kc, kparamTys) <- checkTyClHdr k_hdr + ; unless (null kparamTys) $ do + pstate <- getPState + let enabled = xopt Opt_PolyKinds (dflags pstate) + unless enabled (parseErrorSDoc loc (text "Illegal polymorphic `data kind` declaration (use -XPolyKinds to enable)")) + ; kparams <- checkTyVars k_hdr kparamTys + ; kvars <- checkKVars kparams + ; return $ L loc $ KindDecl + { tcdLName = kc + , tcdKVars = kvars + , tcdTypeCons = ty_cons + , tcdFvs = placeHolderNames + } + } + + where + + -- check that there are no sort signatures + checkKVars tparams + | not (null (hsq_kvs tparams)) = panic "mkTyDataKind" "unexpected sort variables" + | otherwise = mapM checkKVar (hsq_tvs tparams) + + checkKVar bndr = case unLoc bndr of + HsTyVarBndr n Nothing _ -> return (L (getLoc bndr) n) + HsTyVarBndr _ (Just _) _ -> parseErrorSDoc (getLoc bndr) (text "kind parameters may not have sort signatures") + + mkFamInstData :: SrcSpan -> NewOrData -> Maybe CType @@ -147,21 +189,25 @@ mkFamInstData :: SrcSpan -> P (LDataFamInstDecl RdrName) mkFamInstData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv = do { (tc, tparams) <- checkTyClHdr tycl_hdr - ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + -- promotable is always false here, as data families aren't currently + -- promotable + ; defn <- mkDataDefn new_or_data False cType mcxt ksig data_cons maybe_deriv ; return (L loc (DataFamInstDecl { dfid_tycon = tc, dfid_pats = mkHsWithBndrs tparams , dfid_defn = defn, dfid_fvs = placeHolderNames })) } mkDataDefn :: NewOrData + -> Bool -> Maybe CType -> Maybe (LHsContext RdrName) -> Maybe (LHsKind RdrName) -> [LConDecl RdrName] -> Maybe [LHsType RdrName] -> P (HsDataDefn RdrName) -mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv +mkDataDefn new_or_data promotable cType mcxt ksig data_cons maybe_deriv = do { checkDatatypeContext mcxt ; let cxt = fromMaybe (noLoc []) mcxt ; return (HsDataDefn { dd_ND = new_or_data, dd_cType = cType + , dd_try_promote = promotable , dd_ctxt = cxt , dd_cons = data_cons , dd_kindSig = ksig @@ -217,7 +263,7 @@ mkTopSpliceDecl other_expr = SpliceD (SpliceDecl other_ mkTyLit :: Located (HsTyLit) -> P (LHsType RdrName) mkTyLit l = - do allowed <- extension typeLiteralsEnabled + do allowed <- extension dataKindsEnabled if allowed then return (HsTyLit `fmap` l) else parseErrorSDoc (getLoc l) @@ -345,17 +391,17 @@ has_args ((L _ (Match args _ _)) : _) = not (null args) -- This function splits up the type application, adds any pending -- arguments, and converts the type constructor back into a data constructor. -splitCon :: LHsType RdrName +splitCon :: Bool -> LHsType RdrName -> P (Located RdrName, HsConDeclDetails RdrName) -- This gets given a "type" that should look like -- C Int Bool -- or C { x::Int, y::Bool } -- and returns the pieces -splitCon ty +splitCon changeNamespace ty = split ty [] where split (L _ (HsAppTy t u)) ts = split t (u : ts) - split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc + split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon changeNamespace l tc return (data_con, mk_rest ts) split (L l (HsTupleTy _ [])) [] = return (L l (getRdrName unitDataCon), PrefixCon []) -- See Note [Unit tuples] in HsTypes @@ -364,6 +410,12 @@ splitCon ty mk_rest [L _ (HsRecTy flds)] = RecCon flds mk_rest ts = PrefixCon ts +toTyConDetails :: SrcSpan -> HsConDeclDetails RdrName -> P (HsTyConDeclDetails RdrName) +toTyConDetails loc details = case details of + PrefixCon args -> return (PrefixCon args) + InfixCon l r -> return (InfixCon l r) + RecCon _ -> parseErrorSDoc loc (text "record notation is not allowd in a `data kind` declaration") + mkDeprecatedGadtRecordDecl :: SrcSpan -> Located RdrName -> [ConDeclField RdrName] @@ -373,7 +425,7 @@ mkDeprecatedGadtRecordDecl :: SrcSpan -- C { x,y ::Int } :: T a b -- We give it a RecCon details right away mkDeprecatedGadtRecordDecl loc (L con_loc con) flds res_ty - = do { data_con <- tyConToDataCon con_loc con + = do { data_con <- tyConToDataCon True con_loc con ; return (L loc (ConDecl { con_old_rec = True , con_name = data_con , con_explicit = Implicit @@ -397,6 +449,14 @@ mkSimpleConDecl name qvars cxt details , con_res = ResTyH98 , con_doc = Nothing } +mkTyConDecl :: Located RdrName -> HsTyConDeclDetails RdrName + -> TyConDecl RdrName +mkTyConDecl name details + = TyConDecl { tycon_name = name + , tycon_details = details + , tycon_doc = Nothing + } + mkGadtDecl :: [Located RdrName] -> LHsType RdrName -- Always a HsForAllTy -> [ConDecl RdrName] @@ -423,10 +483,10 @@ mkGadtDecl names (L _ (HsForAllTy imp qvars cxt tau)) , con_doc = Nothing } mkGadtDecl _ other_ty = pprPanic "mkGadtDecl" (ppr other_ty) -tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName) -tyConToDataCon loc tc +tyConToDataCon :: Bool -> SrcSpan -> RdrName -> P (Located RdrName) +tyConToDataCon changeNamespace loc tc | isTcOcc (rdrNameOcc tc) - = return (L loc (setRdrNameSpace tc srcDataName)) + = return (L loc newName) | otherwise = parseErrorSDoc loc (msg $$ extra) where @@ -434,6 +494,12 @@ tyConToDataCon loc tc extra | tc == forall_tv_RDR = text "Perhaps you intended to use -XExistentialQuantification" | otherwise = empty + + -- for ordinary data declarations, we change the namespace of the data + -- constructor, but for data kind declarations, we leave them in the type + -- namespace + newName | changeNamespace = setRdrNameSpace tc srcDataName + | otherwise = tc \end{code} Note [Sorting out the result type] diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index b563b25cc4..5f48530145 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -249,7 +249,7 @@ pcTyCon is_enum is_rec is_prom name cType tyvars cons [] -- No stupid theta (DataTyCon cons is_enum) is_rec - is_prom + (if is_prom then Promotable () else NotPromotable) False -- Not in GADT syntax NoParentTyCon @@ -365,9 +365,9 @@ mk_tuple sort arity = (tycon, tuple_con) where tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con sort prom_tc prom_tc = case sort of - BoxedTuple -> Just (mkPromotedTyCon tycon (promoteKind tc_kind)) - UnboxedTuple -> Nothing - ConstraintTuple -> Nothing + BoxedTuple -> Promotable (mkPromotedTyCon tycon (promoteKind tc_kind)) + UnboxedTuple -> NotPromotable + ConstraintTuple -> NotPromotable modu = mkTupleModule sort arity tc_name = mkWiredInName modu (mkTupleOcc tcName sort arity) tc_uniq @@ -435,7 +435,7 @@ eqTyCon = mkAlgTyCon eqTyConName NoParentTyCon NonRecursive False - Nothing -- No parent for constraint-kinded types + NotPromotable -- No parent for constraint-kinded types where kv = kKiVar k = mkTyVarTy kv diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index e1236cac10..8361144f52 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -925,6 +925,22 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars' , tcdDataDefn = defn', tcdFVs = fvs }, fvs) } +rnTyClDecl KindDecl { tcdLName = kcon, tcdKVars = kvars, tcdTypeCons = tycons } + = do kcon' <- lookupLocatedTopBndrRn kcon + let doc = TyDataCtx kcon -- TODO is this right? + fixLoc o = L (getLoc o) + + ((kvars', tycons'), fvs) <- bindHsTyVars doc Nothing (map unLoc kvars) (mkHsQTvs []) $ \ vars -> + do (tycons', fvss) <- mapAndUnzipM (rnTyConDecl doc . unLoc) tycons + return ((hsq_kvs vars, tycons'), plusFVs fvss) + + + return (KindDecl { tcdLName = kcon' + , tcdKVars = zipWith fixLoc kvars kvars' + , tcdTypeCons = zipWith fixLoc tycons tycons' + , tcdFvs = fvs } + , fvs) + rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, @@ -995,6 +1011,7 @@ rnTySyn doc rhs = rnLHsType doc rhs rnDataDefn :: HsDocContext -> HsDataDefn RdrName -> RnM (HsDataDefn Name, FreeVars) rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType + , dd_try_promote = prom , dd_ctxt = context, dd_cons = condecls , dd_kindSig = sig, dd_derivs = derivs }) = do { checkTc (h98_style || null (unLoc context)) @@ -1018,6 +1035,7 @@ 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_ND = new_or_data, dd_cType = cType + , dd_try_promote = prom , dd_ctxt = context', dd_kindSig = sig' , dd_cons = condecls', dd_derivs = derivs' } , all_fvs ) @@ -1103,6 +1121,10 @@ depAnalTyClDecls ds_w_fvs , tcdDataDefn = HsDataDefn { dd_cons = cons } } -> do L _ dc <- cons return (unLoc (con_name dc), data_name) + KindDecl { tcdLName = L _ kind_name + , tcdTypeCons = cons } + -> do L _ tc <- cons + return (unLoc (tycon_name tc), kind_name) _ -> [] \end{code} @@ -1226,6 +1248,29 @@ rnConDeclDetails doc (RecCon fields) -- since that is done by RnNames.extendGlobalRdrEnvRn ; return (RecCon new_fields, fvs) } + +rnTyConDecl :: HsDocContext -> TyConDecl RdrName + -> RnM (TyConDecl Name, FreeVars) +rnTyConDecl doc TyConDecl { tycon_name = name, tycon_details = details + , tycon_doc = mb_doc } + = do name' <- lookupLocatedTopBndrRn name + (details', fvs) <- case details of + + PrefixCon args -> do + (args', fvs) <- rnLHsKinds doc args + return (PrefixCon args', fvs) + + InfixCon l r -> do + (l',lfvs) <- rnLHsKind doc l + (r',rfvs) <- rnLHsKind doc r + return (InfixCon l' r', lfvs `plusFV` rfvs) + + RecCon{} -> panic "rnTyConDecl" "unexpected record constructor" + + return (TyConDecl { tycon_name = name', tycon_details = details' + , tycon_doc = mb_doc } + , fvs) + ------------------------------------------------- deprecRecSyntax :: ConDecl RdrName -> SDoc deprecRecSyntax decl diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index c13ea336e4..32ce4ad2b4 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -4,10 +4,17 @@ \section[RnSource]{Main pass of renamer} \begin{code} +{-# OPTIONS -fno-warn-tabs #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and +-- detab the module (please do the detabbing in a separate patch). See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces +-- for details + module RnTypes ( -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext, - rnHsKind, rnLHsKind, rnLHsMaybeKind, + rnHsKind, rnLHsKind, rnLHsKinds, rnLHsMaybeKind, rnHsSigType, rnLHsInstType, rnConDeclFields, newTyVarNameRn, @@ -308,6 +315,11 @@ rnTyVar is_type rdr_name rnLHsTypes :: HsDocContext -> [LHsType RdrName] -> RnM ([LHsType Name], FreeVars) rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys + + +rnLHsKinds :: HsDocContext -> [LHsKind RdrName] + -> RnM ([LHsKind Name], FreeVars) +rnLHsKinds doc ks = mapFvRn (rnLHsKind doc) ks \end{code} diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index 7e2b0147ea..150246fde8 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -91,7 +91,7 @@ genGenericMetaTyCons tc mod = mkTyCon name = ASSERT( isExternalName name ) buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs NonRecursive - False -- Not promotable + NotPromotable False -- Not GADT syntax NoParentTyCon diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index b0e7d7a789..a8f60d2bad 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -1082,6 +1082,8 @@ kcStrategy (DataDecl { tcdDataDefn = HsDataDefn { dd_kindSig = m_ksig }}) | Just _ <- m_ksig = FullKindSignature | otherwise = ParametricKinds kcStrategy (ClassDecl {}) = ParametricKinds +-- TODO: not sure if this is the right choice for 'data kind' decls +kcStrategy (KindDecl {}) = ParametricKinds -- if the ClosedTypeFamily has no equations, do the defaulting to *, etc. kcStrategyFamDecl :: FamilyDecl Name -> KindCheckingStrategy @@ -1754,6 +1756,13 @@ tc_kind_var_app name arg_kis = do { thing <- tcLookup name ; case thing of AGlobal (ATyCon tc) + | let (args,res) = splitFunTys (tyConKind tc) + , isSuperKind res + -> if length args == length arg_kis + then return (mkTyConApp tc arg_kis) + else tycon_err tc "is not fully applied" + + | otherwise -> do { data_kinds <- xoptM Opt_DataKinds ; unless data_kinds $ addErr (dataKindsErr name) ; case promotableTyCon_maybe tc of @@ -1775,7 +1784,7 @@ tc_kind_var_app name arg_kis -> return (mkAppTys (mkTyVarTy kind_var) arg_kis) -- It is in scope, but not what we expected - AThing _ + AThing _ | isTyVarName name -> failWithTc (ptext (sLit "Type variable") <+> quotes (ppr name) <+> ptext (sLit "used in a kind")) diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 9f89afe0af..b84037e7aa 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -698,8 +698,8 @@ tcDataFamInstDecl mb_clsinfo parent = FamInstTyCon axiom fam_tc pats' roles = map (const Nominal) tvs' rep_tc = buildAlgTyCon rep_tc_name tvs' roles cType stupid_theta tc_rhs - Recursive - False -- No promotable to the kind level + Recursive + NotPromotable -- No promotable to the kind level h98_syntax parent -- We always assume that indexed types are recursive. Why? -- (1) Due to their open nature, we can never be sure that a diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index f4e4dabd1b..99a3584ab2 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -118,6 +118,25 @@ tcTyAndClassDecls boot_details tyclds_s -- remaining groups are typecheck in the extended global env tcTyClGroup :: ModDetails -> TyClGroup Name -> TcM TcGblEnv +tcTyClGroup boot_details decls + | all (isKindDecl . unLoc) decls + = do (kcons, _) <- fixM $ \ ~(_, conss) -> do + let rec_info = panic "tcTyClGroup" "rec_info" + + kind_cons <- zipWithM (\ix d -> addLocM (mkKindCon rec_info (conss !! ix)) d) [0 ..] decls + let kind_env = [ (kind_name, panic "tcTyClGroup" "kind") + | L _ KindDecl { tcdLName = L _ kind_name } <- decls ] + + final_conss <- tcExtendRecEnv (zipRecTyClss kind_env (map ATyCon kind_cons)) + (mapM (addLocM (tcKindDecl rec_info)) decls) + + return (kind_cons, final_conss) + + let tycons = [ ATyCon x | x <- kcons ] + tcExtendGlobalEnv tycons (tcAddImplicits tycons) + + + -- Typecheck one strongly-connected component of type and class decls tcTyClGroup boot_details tyclds = do { -- Step 1: kind-check this group and returns the final @@ -128,10 +147,16 @@ tcTyClGroup boot_details tyclds ; traceTc "tcTyAndCl generalized kinds" (ppr names_w_poly_kinds) -- the checkNoErrs is necessary to fix #7175. + + -- If any of the data declarations are explicitly not promotable, + -- the whole group is not promotable. + ; let dont_promote = or [ not (dd_try_promote dd) + | DataDecl { tcdDataDefn = dd } <- map unLoc tyclds ] + -- Step 2: type-check all groups together, returning -- the final TyCons and Classes ; tyclss <- fixM $ \ rec_tyclss -> do - { let rec_flags = calcRecFlags boot_details role_annots rec_tyclss + { let rec_flags = calcRecFlags dont_promote boot_details role_annots rec_tyclss -- Populate environment with knot-tied ATyCon for TyCons -- NB: if the decls mention any ill-staged data cons @@ -402,6 +427,10 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name role_annots' = role_annots ++ replicate num_extra_tvs Nothing ; return ((main_pr : inner_prs), role_annots') } +getInitialKind KindDecl {} + = failWithTc (ptext (sLit "`data kind` declarations can only be recursive") + <+> ptext (sLit "with other `data kind` declarations")) + getInitialKind (FamDecl { tcdFam = decl }) = do { pairs <- getFamDeclInitialKind decl ; return (pairs, []) } @@ -493,6 +522,9 @@ kcTyClDecl (DataDecl { tcdLName = L _ name, tcdTyVars = hs_tvs, tcdDataDefn = de kcTyClDecl decl@(SynDecl {}) = pprPanic "kcTyClDecl" (ppr decl) +-- do we need to do any sort checking here? +kcTyClDecl (KindDecl {}) = return () + kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs , tcdCtxt = ctxt, tcdSigs = sigs }) = kcTyClTyVars name hs_tvs $ @@ -620,6 +652,9 @@ tcTyClDecl1 _parent rec_info tcTyClTyVars tc_name tvs $ \ tvs' kind -> tcDataDefn rec_info tc_name tvs' kind defn +tcTyClDecl1 _parent _rec_info KindDecl {} + = failWithTc (ptext (sLit "'data kind' declarations can not appear in a recursive group")) + tcTyClDecl1 _parent rec_info (ClassDecl { tcdLName = L _ class_name, tcdTyVars = tvs , tcdCtxt = ctxt, tcdMeths = meths @@ -757,7 +792,7 @@ tcFamDecl1 parent roles = map (const Nominal) final_tvs tycon = buildAlgTyCon tc_name final_tvs roles Nothing [] DataFamilyTyCon Recursive - False -- Not promotable to the kind level + NotPromotable True -- GADT syntax parent ; return [ATyCon tycon] } @@ -776,12 +811,54 @@ tcTySynRhs rec_info tc_name tvs kind hs_ty kind NoParentTyCon ; return [ATyCon tycon] } +mkKindCon :: RecTyInfo -> [TyCon] -> TyClDecl Name -> TcM TyCon +mkKindCon _rec_info tycons KindDecl { tcdLName = L _ kind_name + , tcdKVars = lknames } = + do let knames = map unLoc lknames + kvars <- mapM (\n -> newSigTyVar n superKind) knames + return $ mkAlgTyCon + kind_name + sKind + kvars + [] -- XXX roles here? + Nothing + [] + (DataKindTyCon tycons) + NoParentTyCon + -- TODO, make the rec_info work + NonRecursive --(rti_is_rec rec_info kind_name) + False + NotPromotable + where + -- for now, we assume all kind variables have sort BOX. + sKind = mkFunTys (replicate arity superKind) superKind + arity = length lknames + +mkKindCon _ _ _ = + panic "mkKindCon" "non 'data kind' declaration" + +tcKindDecl :: RecTyInfo -> TyClDecl Name -> TcM [TyCon] +tcKindDecl rec_info KindDecl { tcdLName = L _ kind_name, tcdKVars = lknames + , tcdTypeCons = cons } + = do traceTc "tcKindDecl" (ppr kind_name) + + ~(ATyCon kcon) <- tcLookupGlobal kind_name + let kvars = tyConTyVars kcon + knames = map unLoc lknames + kind = mkTyConApp kcon (mkTyVarTys kvars) + tcExtendTyVarEnv2 (knames `zip` kvars) + (mapM (addLocM (tcTyConDecl kvars kind)) cons) + +tcKindDecl _ _ + = panic "tcKindDecl" "unexpected non-KindDecl constructor" + tcDataDefn :: RecTyInfo -> Name -> [TyVar] -> Kind -> HsDataDefn Name -> TcM [TyThing] -- NB: not used for newtype/data instances (whether associated or not) tcDataDefn rec_info tc_name tvs kind (HsDataDefn { dd_ND = new_or_data, dd_cType = cType + , dd_try_promote = try_promote , dd_ctxt = ctxt, dd_kindSig = mb_ksig , dd_cons = cons }) = do { extra_tvs <- tcDataKindSig kind @@ -812,9 +889,13 @@ tcDataDefn rec_info tc_name tvs kind DataType -> return (mkDataTyConRhs data_cons) NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs tc_name tycon (head data_cons) + ; let prom_info + | not try_promote = NeverPromote + | rti_promotable rec_info = Promotable () + | otherwise = NotPromotable ; return (buildAlgTyCon tc_name final_tvs roles cType stupid_theta tc_rhs (rti_is_rec rec_info tc_name) - (rti_promotable rec_info) + prom_info (not h98_syntax) NoParentTyCon) } ; return [ATyCon tycon] } \end{code} @@ -1303,6 +1384,19 @@ rejigConRes tmpl_tvs res_tmpl dc_tvs (ResTyGADT res_ty) new_tmpl = updateTyVarKind (substTy subst) tmpl | otherwise = pprPanic "tcResultType" (ppr res_ty) ex_tvs = dc_tvs `minusList` univ_tvs + + +tcTyConDecl :: [TyVar] -> Kind -> TyConDecl Name -> TcM TyCon +tcTyConDecl kvars kind TyConDecl { tycon_name = name, tycon_details = details } + = do ks <- case details of + PrefixCon args -> mapM tcLHsKind args + InfixCon l r -> mapM tcLHsKind [l,r] + RecCon {} -> panic "tcTyConDecl" "unexpected record constructor" + let (kcon,_) = splitTyConApp kind + con_kind = mkPiKinds kvars (mkFunTys ks kind) + return (mkDataKindTyCon kcon (unLoc name) con_kind) + + \end{code} Note [Substitution in template variables kinds] diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index 5091cab802..077b4a91ba 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -360,11 +360,11 @@ data RecTyInfo = RTI { rti_promotable :: Bool , rti_roles :: Name -> [Role] , rti_is_rec :: Name -> RecFlag } -calcRecFlags :: ModDetails -> RoleAnnots -> [TyThing] -> RecTyInfo +calcRecFlags :: Bool -> ModDetails -> RoleAnnots -> [TyThing] -> RecTyInfo -- The 'boot_names' are the things declared in M.hi-boot, if M is the current module. -- Any type constructors in boot_names are automatically considered loop breakers -calcRecFlags boot_details mrole_env tyclss - = RTI { rti_promotable = is_promotable +calcRecFlags prevent_promotion boot_details mrole_env tyclss + = RTI { rti_promotable = not prevent_promotion && is_promotable , rti_roles = roles , rti_is_rec = is_rec } where @@ -497,6 +497,7 @@ isPromotableTyCon rec_tycons tc NewTyCon { data_con = c } -> ok_con c AbstractTyCon {} -> False DataFamilyTyCon {} -> False + DataKindTyCon {} -> False where ok_kind kind = all isLiftedTypeKind args && isLiftedTypeKind res diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 47e64301b0..8ccbcc9869 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -14,6 +14,8 @@ module TyCon( AlgTyConRhs(..), visibleDataCons, TyConParent(..), isNoParent, SynTyConRhs(..), Role(..), + PromotionInfo(..), + PromotionFlavor, -- ** Constructing TyCons mkAlgTyCon, @@ -27,6 +29,7 @@ module TyCon( mkForeignTyCon, mkPromotedDataCon, mkPromotedTyCon, + mkDataKindTyCon, -- ** Predicates on TyCons isAlgTyCon, @@ -38,8 +41,10 @@ module TyCon( isDecomposableTyCon, isForeignTyCon, isPromotedDataCon, isPromotedTyCon, - isPromotedDataCon_maybe, isPromotedTyCon_maybe, + isPromotedTyCon_maybe, promotableTyCon_maybe, promoteTyCon, + promotedDataConParent, + promotableTyConInfo, isInjectiveTyCon, isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, @@ -74,6 +79,7 @@ module TyCon( algTyConRhs, newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe, tupleTyConBoxity, tupleTyConSort, tupleTyConArity, + tyConDataKind_maybe, isTyConDataKind, -- ** Manipulating TyCons tcExpandTyCon_maybe, coreExpandTyCon_maybe, @@ -86,6 +92,10 @@ module TyCon( tyConPrimRep, primRepSizeW, primElemRepSizeB, + -- * Kind Constructors + KCon, + kConTypeCons, kConTypeCons_maybe, + -- * Recursion breaking RecTcChecker, initRecTc, checkRecTc ) where @@ -93,7 +103,7 @@ module TyCon( #include "HsVersions.h" import {-# SOURCE #-} TypeRep ( Kind, Type, PredType ) -import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon ) +import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon, dataConTyCon ) import Var import Class @@ -375,7 +385,7 @@ data TyCon -- or family instances, respectively. -- See also 'synTcParent' - tcPromoted :: Maybe TyCon -- ^ Promoted TyCon, if any + tcPromoted :: PromotionFlavor -- ^ Promoted TyCon, if any } -- | Represents the infinite family of tuple type constructors, @@ -388,7 +398,7 @@ data TyCon tyConTupleSort :: TupleSort, tyConTyVars :: [TyVar], dataCon :: DataCon, -- ^ Corresponding tuple data constructor - tcPromoted :: Maybe TyCon -- Nothing for unboxed tuples + tcPromoted :: PromotionFlavor -- Nothing for unboxed tuples } -- | Represents type synonyms @@ -432,14 +442,17 @@ data TyCon -- holds the name of the imported thing } - -- | Represents promoted data constructor. + -- | Represents promoted data constructor or type constructors introduced by a + -- 'data kind' declaration. | PromotedDataCon { -- See Note [Promoted data constructors] - tyConUnique :: Unique, -- ^ Same Unique as the data constructor - tyConName :: Name, -- ^ Same Name as the data constructor + tyConUnique :: Unique, -- ^ For promoted data cons, same Unique as the data constructor + tyConName :: Name, -- ^ For promoted data cons, same Name as the data constructor tyConArity :: Arity, tc_roles :: [Role], -- ^ Roles: N for kind vars, R for type vars tc_kind :: Kind, -- ^ Translated type of the data constructor - dataCon :: DataCon -- ^ Corresponding data constructor + parentTyCon :: TyCon -- ^ Corresponding parent LHS constructor. + -- Type constructor for the promoted case, kind + -- constructor for the 'data kind' case. } -- | Represents promoted type constructor. @@ -453,9 +466,27 @@ data TyCon deriving Typeable +-- | Kind constructor (a TyCon that returns kind super kind). +type KCon = TyCon + -- | Names of the fields in an algebraic record type type FieldLabel = Name +type PromotionFlavor = PromotionInfo TyCon + +-- | How promotion should operate for an AlgTyCon. +data PromotionInfo con + = NeverPromote -- ^ Promotion is explicitly disabled by 'data type' syntax + | NotPromotable -- ^ Promotion is not possible + | Promotable con -- ^ Promotion is possible, use this con + deriving (Typeable) + +instance Functor PromotionInfo where + fmap f p = case p of + Promotable a -> Promotable (f a) + NeverPromote -> NeverPromote + NotPromotable -> NotPromotable + -- | Represents right-hand-sides of 'TyCon's for algebraic types data AlgTyConRhs @@ -526,6 +557,14 @@ data AlgTyConRhs -- again check Trac #1072. } + -- | Constructors for the rhs of a 'data kind' declaration. + | DataKindTyCon { + data_kind_cons :: [TyCon] -- ^ Type constructors for the RHS of the + -- 'data kind' declaration. + -- + -- INVARIANT: These will be all + -- @AbstractTyCon@, as defined above. + } \end{code} Note [AbstractTyCon and type equality] @@ -542,6 +581,7 @@ visibleDataCons (AbstractTyCon {}) = [] visibleDataCons DataFamilyTyCon {} = [] visibleDataCons (DataTyCon{ data_cons = cs }) = cs visibleDataCons (NewTyCon{ data_con = c }) = [c] +visibleDataCons DataKindTyCon{} = [] -- ^ Both type classes as well as family instances imply implicit -- type constructors. These implicit type constructors refer to their parent @@ -919,9 +959,9 @@ mkAlgTyCon :: Name -> TyConParent -> RecFlag -- ^ Is the 'TyCon' recursive? -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? - -> Maybe TyCon -- ^ Promoted version + -> PromotionFlavor -- ^ Promoted version -> TyCon -mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_tc +mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_info = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -935,7 +975,7 @@ mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_t algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, algTcRec = is_rec, algTcGadtSyntax = gadt_syn, - tcPromoted = prom_tc + tcPromoted = prom_info } -- | Simpler specialization of 'mkAlgTyCon' for classes @@ -943,7 +983,7 @@ mkClassTyCon :: Name -> Kind -> [TyVar] -> [Role] -> AlgTyConRhs -> Class -> Rec mkClassTyCon name kind tyvars roles rhs clas is_rec = mkAlgTyCon name kind tyvars roles Nothing [] rhs (ClassTyCon clas) is_rec False - Nothing -- Class TyCons are not pormoted + NotPromotable -- Class TyCons are not pormoted mkTupleTyCon :: Name -> Kind -- ^ Kind of the resulting 'TyCon' @@ -951,9 +991,9 @@ mkTupleTyCon :: Name -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' -> DataCon -> TupleSort -- ^ Whether the tuple is boxed or unboxed - -> Maybe TyCon -- ^ Promoted version + -> PromotionFlavor -- ^ Promoted version -> TyCon -mkTupleTyCon name kind arity tyvars con sort prom_tc +mkTupleTyCon name kind arity tyvars con sort prom_info = TupleTyCon { tyConUnique = nameUnique name, tyConName = name, @@ -962,7 +1002,7 @@ mkTupleTyCon name kind arity tyvars con sort prom_tc tyConTupleSort = sort, tyConTyVars = tyvars, dataCon = con, - tcPromoted = prom_tc + tcPromoted = prom_info } -- ^ Foreign-imported (.NET) type constructors are represented @@ -1040,11 +1080,24 @@ mkPromotedDataCon con name unique kind roles tyConArity = arity, tc_roles = roles, tc_kind = kind, - dataCon = con + parentTyCon = dataConTyCon con } where arity = length roles +-- | Construct a type constructor for a type introduced by a 'data kind' +-- declaration. +mkDataKindTyCon :: TyCon -> Name -> Kind -> TyCon +mkDataKindTyCon kc name kind + = PromotedDataCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConArity = 0, + tc_roles = [], -- XXX is this correct? + tc_kind = kind, + parentTyCon = kc + } + -- | Create a promoted type constructor 'TyCon' -- Somewhat dodgily, we give it the same Name -- as the type constructor itself @@ -1111,6 +1164,7 @@ isDataTyCon (AlgTyCon {algTcRhs = rhs}) NewTyCon {} -> False DataFamilyTyCon {} -> False AbstractTyCon {} -> False -- We don't know, so return False + DataKindTyCon {} -> False isDataTyCon (TupleTyCon {tyConTupleSort = sort}) = isBoxed (tupleSortBoxity sort) isDataTyCon _ = False @@ -1135,6 +1189,7 @@ isDistinctAlgRhs (DataTyCon {}) = True isDistinctAlgRhs (DataFamilyTyCon {}) = True isDistinctAlgRhs (AbstractTyCon distinct) = distinct isDistinctAlgRhs (NewTyCon {}) = False +isDistinctAlgRhs (DataKindTyCon{}) = True -- | Is this 'TyCon' that for a @newtype@ isNewTyCon :: TyCon -> Bool @@ -1260,6 +1315,15 @@ tyConAssoc_maybe tc = case tyConParent tc of AssocFamilyTyCon cls -> Just cls _ -> Nothing +-- | Is this TyCon defined as part of the RHS of a 'data kind' declaration? +isTyConDataKind :: TyCon -> Bool +isTyConDataKind tc = isJust (tyConDataKind_maybe tc) + +tyConDataKind_maybe :: TyCon -> Maybe TyCon +tyConDataKind_maybe tc = case tc of + PromotedDataCon { parentTyCon = s@AlgTyCon { algTcRhs = DataKindTyCon {} } } -> Just s + _ -> Nothing + -- The unit tycon didn't used to be classed as a tuple tycon -- but I thought that was silly so I've undone it -- If it can't be for some reason, it should be a AlgTyCon @@ -1303,10 +1367,15 @@ isRecursiveTyCon :: TyCon -> Bool isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True isRecursiveTyCon _ = False +promotableTyConInfo :: TyCon -> PromotionFlavor +promotableTyConInfo (AlgTyCon { tcPromoted = prom }) = prom +promotableTyConInfo (TupleTyCon { tcPromoted = prom }) = prom +promotableTyConInfo _ = NotPromotable + promotableTyCon_maybe :: TyCon -> Maybe TyCon -promotableTyCon_maybe (AlgTyCon { tcPromoted = prom }) = prom -promotableTyCon_maybe (TupleTyCon { tcPromoted = prom }) = prom -promotableTyCon_maybe _ = Nothing +promotableTyCon_maybe tc = case promotableTyConInfo tc of + Promotable tycon -> Just tycon + _ -> Nothing promoteTyCon :: TyCon -> TyCon promoteTyCon tc = case promotableTyCon_maybe tc of @@ -1333,10 +1402,11 @@ isPromotedDataCon :: TyCon -> Bool isPromotedDataCon (PromotedDataCon {}) = True isPromotedDataCon _ = False --- | Retrieves the promoted DataCon if this is a PromotedDataCon; -isPromotedDataCon_maybe :: TyCon -> Maybe DataCon -isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc -isPromotedDataCon_maybe _ = Nothing +-- | Returns the TyCon for the parent when this is a normal data type, +-- and the TyCon for the kind definition if this is a 'data kind' definition. +promotedDataConParent :: TyCon -> Maybe TyCon +promotedDataConParent PromotedDataCon { parentTyCon = tc } = Just tc +promotedDataConParent _ = Nothing -- | Identifies implicit tycons that, in particular, do not go into interface -- files (because they are implicitly reconstructed when the interface is @@ -1425,6 +1495,14 @@ tyConDataCons_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Jus tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con] tyConDataCons_maybe _ = Nothing + +kConTypeCons :: KCon -> [TyCon] +kConTypeCons kcon = kConTypeCons_maybe kcon `orElse` [] + +kConTypeCons_maybe :: KCon -> Maybe [TyCon] +kConTypeCons_maybe AlgTyCon { algTcRhs = DataKindTyCon cons } = Just cons +kConTypeCons_maybe _ = Nothing + -- | Determine the number of value constructors a 'TyCon' has. Panics if the 'TyCon' -- is not algebraic or a tuple tyConFamilySize :: TyCon -> Int @@ -1620,7 +1698,9 @@ instance Outputable TyCon where ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) pprPromotionQuote :: TyCon -> SDoc -pprPromotionQuote (PromotedDataCon {}) = char '\'' -- Quote promoted DataCons in types +pprPromotionQuote con@(PromotedDataCon {}) + | isTyConDataKind con = empty + | otherwise = char '\'' -- Quote promoted DataCons in types pprPromotionQuote (PromotedTyCon {}) = ifPprDebug (char '\'') pprPromotionQuote _ = empty -- However, we don't quote TyCons in kinds -- e.g. type family T a :: Bool -> * diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 2b127369d4..c64d7d1a34 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -63,7 +63,7 @@ module TypeRep ( #include "HsVersions.h" -import {-# SOURCE #-} DataCon( DataCon, dataConTyCon, dataConName ) +import {-# SOURCE #-} DataCon( DataCon, dataConName ) import {-# SOURCE #-} Type( noParenPred, isPredTy ) -- Transitively pulls in a LOT of stuff, better to break the loop -- friends: @@ -681,8 +681,7 @@ pprTcApp p pp tc tys = pprPromotionQuote tc <> tupleParens (tupleTyConSort tc) (sep (punctuate comma (map (pp TopPrec) tys))) - | Just dc <- isPromotedDataCon_maybe tc - , let dc_tc = dataConTyCon dc + | Just dc_tc <- promotedDataConParent tc , isTupleTyCon dc_tc , let arity = tyConArity dc_tc -- E.g. 3 for (,,) k1 k2 k3 t1 t2 t3 ty_args = drop arity tys -- Drop the kind args diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs index 37358c9bdf..8a54776879 100644 --- a/compiler/vectorise/Vectorise/Generic/PData.hs +++ b/compiler/vectorise/Vectorise/Generic/PData.hs @@ -57,7 +57,7 @@ buildDataFamInst name' fam_tc vect_tc rhs [] -- no stupid theta rhs rec_flag -- FIXME: is this ok? - False -- Not promotable + NotPromotable False -- not GADT syntax (FamInstTyCon ax fam_tc pat_tys) ; liftDs $ newFamInst (DataFamilyInst rep_tc) ax } diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs index 935ea32c69..ee8e29fd2e 100644 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -106,7 +106,7 @@ vectTyConDecl tycon name' [] -- no stupid theta rhs' -- new constructor defs rec_flag -- whether recursive - False -- Not promotable + NotPromotable gadt_flag -- whether in GADT syntax NoParentTyCon } @@ -151,6 +151,9 @@ vectAlgTyConRhs tc (NewTyCon {}) cantVectorise dflags noNewtypeErr (ppr tc) where noNewtypeErr = "Vectorisation of newtypes not supported yet; please use a 'data' declaration" +vectAlgTyConRhs tc DataKindTyCon{} = + do dflags <- getDynFlags + cantVectorise dflags "Can't vectorise 'data kind' declarations" (ppr tc) -- |Vectorise a data constructor by vectorising its argument and return types.. -- diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index c825da90c7..3246c5a3df 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -6152,6 +6152,81 @@ no way to quote a data constructor or type constructor whose second character is a single quote.</para> </sect2> +<sect2 id="restricting-promotion"> +<title>Restricting Promotion</title> +<para> +By default, promotable types are always promoted. In some cases, the promoted +kind is not necessary, so to avoid name collisions the programmer may disable +datatype promotion explicitly, by using a <literal>data type</literal> +declaration. +</para> + +<para> +For example, if we wanted to declare a type for the natural numbers that is not +promoted, we could use the following declaration: +<programlisting> +data type Nat = Ze | Su Nat +</programlisting> +This declaration will introduce a type <literal>Nat</literal>, and two +value-level data constructors, <literal>Ze</literal> and <literal>Su</literal> +(i.e., as though -XDataKinds was disabled for this declaration) +</para> +</sect2> + +<sect2 id="kind-only-declarations"> +<title>Kind-only Declarations</title> +<para> +Sometimes we may want to define only a new kind, without needing to promote a +type declaration. Typically, there are two reasons for this: (i) to avoid name +clashes with existing types, and (ii) defining kinds that use primitive kinds +such as <literal>*</literal> that are not also types. This is done by using a +<literal>data kind</literal> declaration. +</para> + +<para> +For example, to declare only the kind of natural numbers, without the +corresponding type and value-level constructors, we would use: +<programlisting> +data kind Nat = Ze | Su Nat +</programlisting> +This introduces a new kind <literal>Nat</literal> and two new type constructors +<literal>Ze :: Nat</literal> and <literal>Su :: Nat -> Nat</literal>. +</para> + +<para> +As another example, consider the following declaration: +<programlisting> +data kind Area = Array Nat Area + | Stored * +</programlisting> +This introduces a new kind <literal>Area</literal> and two type constructors, +<literal>Array :: Nat -> Area -> Area</literal>, and <literal>Stored :: * -> +Area</literal>. Note that we could not declare this type by promotion, because +both kinds <literal>Nat</literal> and <literal>*</literal> don't exist at the +type-level. +</para> + +<para> +New kinds introduced with <literal>data kind</literal> may have kind parameters, +although this requires that <literal>-XPolyKinds</literal> be enabled as the +resulting type constructors have polymorphic kinds. For example, a kind-only +declaration for lists would look like: +<programlisting> +data kind List a = Nil | Cons a (List a) +</programlisting> +This introduces a new kind <literal>List</literal> and two type constructors, +<literal>Nil :: forall a. a -> List a</literal>, and <literal>Cons :: forall a. +a -> List a -> List a</literal>. +</para> + +<para> +As kinds and types currently share a namespace, <literal>data kind</literal> and +<literal>data type</literal> declarations <i>in the same module</i> can still +conflict. However, if they are in separate modules, this can be controlled by +use of the module system. +</para> +</sect2> + <sect2 id="promoted-lists-and-tuples"> <title>Promoted lists and tuples types</title> <para> |