From 13d4096e0668e9f80a8601122affc64f8be295de Mon Sep 17 00:00:00 2001
From: Trevor Elliott <trevor@galois.com>
Date: Sun, 8 Sep 2013 17:46:48 -0700
Subject: [PATCH] Fix how we're using roles with `data kind` declarations
---
compiler/iface/IfaceSyn.lhs | 11 +++++++----
compiler/iface/MkIface.lhs | 3 ++-
compiler/iface/TcIface.lhs | 5 +++--
compiler/typecheck/TcTyClsDecls.lhs | 15 ++++++++-------
compiler/types/TyCon.lhs | 8 ++++----
5 files changed, 24 insertions(+), 18 deletions(-)
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index b12906b3b44..ca772ac9633 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -436,19 +436,22 @@ instance Binary IfaceBang where
data IfaceTyConDecl
= IfTyCon {
- ifTyConOcc :: OccName, -- constructor name
- ifTyConArgKs :: [IfaceKind] -- constructor argument kinds
+ ifTyConOcc :: OccName, -- constructor name
+ ifTyConArgKs :: [IfaceKind], -- constructor argument kinds
+ ifTyConRoles :: [Role] -- constructor argument roles
}
instance Binary IfaceTyConDecl where
- put_ bh (IfTyCon a1 a2) = do
+ put_ bh (IfTyCon a1 a2 a3) = do
put_ bh (occNameFS a1)
put_ bh a2
+ put_ bh a3
get bh = do
a1 <- get bh
a2 <- get bh
+ a3 <- get bh
occ <- return $! mkOccNameFS tcName a1
- return (IfTyCon occ a2)
+ return (IfTyCon occ a2 a3)
data IfaceClsInst
= IfaceClsInst { ifInstCls :: IfExtName, -- See comments with
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 6764c916eb4..3fff2b81c73 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1566,7 +1566,8 @@ tyConToIfaceDecl env tycon
ifaceTyConDecl ty_con
= IfTyCon { ifTyConOcc = getOccName (tyConName ty_con),
- ifTyConArgKs = map (tidyToIfaceType emptyTidyEnv) args }
+ ifTyConArgKs = map (tidyToIfaceType emptyTidyEnv) args,
+ ifTyConRoles = tyConRoles ty_con }
where
(args,_) = splitFunTys (tyConKind ty_con)
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index d6b6a55abe1..2d18a74d1b1 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -668,11 +668,12 @@ tcIfaceDataCons tycon_name tycon _ if_cons
; return (HsUnpack (Just co)) }
tcIfaceTyConDecl :: Kind -> KCon -> IfaceTyConDecl -> IfL TyCon
-tcIfaceTyConDecl kind kcon IfTyCon { ifTyConOcc = occ_name, ifTyConArgKs = args }
+tcIfaceTyConDecl kind kcon IfTyCon { ifTyConOcc = occ_name, ifTyConArgKs = args,
+ ifTyConRoles = roles }
= 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))
+ return (mkDataKindTyCon kcon name (mkFunTys kinds kind) roles)
where
pp_name = ptext (sLit "Type constructor") <+> ppr occ_name
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 99a3584ab20..d348e8b9850 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -118,7 +118,7 @@ tcTyAndClassDecls boot_details tyclds_s
-- remaining groups are typecheck in the extended global env
tcTyClGroup :: ModDetails -> TyClGroup Name -> TcM TcGblEnv
-tcTyClGroup boot_details decls
+tcTyClGroup _boot_details decls
| all (isKindDecl . unLoc) decls
= do (kcons, _) <- fixM $ \ ~(_, conss) -> do
let rec_info = panic "tcTyClGroup" "rec_info"
@@ -820,13 +820,12 @@ mkKindCon _rec_info tycons KindDecl { tcdLName = L _ kind_name
kind_name
sKind
kvars
- [] -- XXX roles here?
+ (replicate (length kvars) Nominal) -- no interesting kind equality
Nothing
[]
(DataKindTyCon tycons)
NoParentTyCon
- -- TODO, make the rec_info work
- NonRecursive --(rti_is_rec rec_info kind_name)
+ NonRecursive -- XXX is this OK?
False
NotPromotable
where
@@ -838,8 +837,8 @@ 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 }
+tcKindDecl _rec_info KindDecl { tcdLName = L _ kind_name, tcdKVars = lknames
+ , tcdTypeCons = cons }
= do traceTc "tcKindDecl" (ppr kind_name)
~(ATyCon kcon) <- tcLookupGlobal kind_name
@@ -1394,7 +1393,9 @@ tcTyConDecl kvars kind TyConDecl { tycon_name = name, tycon_details = details }
RecCon {} -> panic "tcTyConDecl" "unexpected record constructor"
let (kcon,_) = splitTyConApp kind
con_kind = mkPiKinds kvars (mkFunTys ks kind)
- return (mkDataKindTyCon kcon (unLoc name) con_kind)
+ roles = replicate (length kvars) Nominal
+ ++ replicate (length ks) Representational
+ return (mkDataKindTyCon kcon (unLoc name) con_kind roles)
\end{code}
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 8ccbcc9869e..9308713dae7 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -1087,13 +1087,13 @@ mkPromotedDataCon con name unique kind roles
-- | Construct a type constructor for a type introduced by a 'data kind'
-- declaration.
-mkDataKindTyCon :: TyCon -> Name -> Kind -> TyCon
-mkDataKindTyCon kc name kind
+mkDataKindTyCon :: TyCon -> Name -> Kind -> [Role] -> TyCon
+mkDataKindTyCon kc name kind roles
= PromotedDataCon {
tyConName = name,
tyConUnique = nameUnique name,
- tyConArity = 0,
- tc_roles = [], -- XXX is this correct?
+ tyConArity = length roles,
+ tc_roles = roles,
tc_kind = kind,
parentTyCon = kc
}
--
GitLab