Commit 86bf4164 authored by trevor's avatar trevor
Browse files

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 c798a8c6
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 4b5238a4
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 9e185cc0
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 2f99cdb9
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 e56b9d59
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 3660ef95
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 569b2652
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 e4fc6fd0
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 73991d61
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 db9b6310
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.
parent c798a8c6
......@@ -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}
......
......@@ -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' }
......
......@@ -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
......
......@@ -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 } })
......
......@@ -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) &&&
......
......@@ -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
......
......@@ -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
......
......@@ -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))
......
......@@ -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") $$
......
......@@ -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
......@@ -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