Commit e5257f8f authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Fix tyConToIfaceDecl (Trac #9190)

There are three bugs here, one serious

 * We were failing to tidy the type arguments in an IfTyConParent
   This is what was causing Trac #9190.

 * toIfaceTcArgs is careful to suppress kind arguments, but there
   was a clone, tidyToIfaceTcArgs in IfaceSyn which didn't.
   Now the latter goes via the former.

 * When pretty-printing a IfaceDecl for an algebraic data type, and
   doing so in Haskell-98 syntax, we were silently assuming that the
   universal type variables of the TyCon and the DataCon were the
   same. But that has not been true for some time. Result: a very
   confusing display.

   Solution: during the conversion to IfaceSyn, take the opportunity
   to make the universal type variables line up exactly.  This is very
   easy to do, makes the pretty-printing easy, and leaves open the future
   possiblity of not serialising the universal type variables of the
   data constructor.
parent 748bec48
......@@ -1534,7 +1534,7 @@ coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches
= IfaceAxiom { ifName = name
, ifTyCon = toIfaceTyCon tycon
, ifRole = role
, ifAxBranches = brListMap (coAxBranchToIfaceBranch
, ifAxBranches = brListMap (coAxBranchToIfaceBranch tycon
(brListMap coAxBranchLHS branches))
branches }
where
......@@ -1543,10 +1543,10 @@ coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches
-- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches
-- to incompatible indices
-- See Note [Storing compatibility] in CoAxiom
coAxBranchToIfaceBranch :: [[Type]] -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch lhs_s
coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch tc lhs_s
branch@(CoAxBranch { cab_incomps = incomps })
= (coAxBranchToIfaceBranch' branch) { ifaxbIncomps = iface_incomps }
= (coAxBranchToIfaceBranch' tc branch) { ifaxbIncomps = iface_incomps }
where
iface_incomps = map (expectJust "iface_incomps"
. (flip findIndex lhs_s
......@@ -1554,11 +1554,11 @@ coAxBranchToIfaceBranch lhs_s
. coAxBranchLHS) incomps
-- use this one for standalone branches without incompatibles
coAxBranchToIfaceBranch' :: CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch' (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs
, cab_roles = roles, cab_rhs = rhs })
coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch
coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_lhs = lhs
, cab_roles = roles, cab_rhs = rhs })
= IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tv_bndrs
, ifaxbLHS = tidyToIfaceTcArgs env1 lhs
, ifaxbLHS = tidyToIfaceTcArgs env1 tc lhs
, ifaxbRoles = roles
, ifaxbRHS = tidyToIfaceType env1 rhs
, ifaxbIncomps = [] }
......@@ -1577,17 +1577,17 @@ tyConToIfaceDecl env tycon
| Just syn_rhs <- synTyConRhs_maybe tycon
= IfaceSyn { ifName = getOccName tycon,
ifTyVars = toIfaceTvBndrs tyvars,
ifTyVars = if_tc_tyvars,
ifRoles = tyConRoles tycon,
ifSynRhs = to_ifsyn_rhs syn_rhs,
ifSynKind = tidyToIfaceType env1 (synTyConResKind tycon) }
ifSynKind = tidyToIfaceType tc_env1 (synTyConResKind tycon) }
| isAlgTyCon tycon
= IfaceData { ifName = getOccName tycon,
ifCType = tyConCType tycon,
ifTyVars = toIfaceTvBndrs tyvars,
ifTyVars = if_tc_tyvars,
ifRoles = tyConRoles tycon,
ifCtxt = tidyToIfaceContext env1 (tyConStupidTheta tycon),
ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),
ifCons = ifaceConDecls (algTyConRhs tycon),
ifRec = boolToRecFlag (isRecursiveTyCon tycon),
ifGadtSyntax = isGadtSyntaxTyCon tycon,
......@@ -1611,26 +1611,27 @@ tyConToIfaceDecl env tycon
ifPromotable = False,
ifParent = IfNoParent }
where
(env1, tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon)
(tc_env1, tc_tyvars) = tidyTyClTyVarBndrs env (tyConTyVars tycon)
if_tc_tyvars = toIfaceTvBndrs tc_tyvars
funAndPrimTyVars = toIfaceTvBndrs $ take (tyConArity tycon) alphaTyVars
parent = case tyConFamInstSig_maybe tycon of
Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)
(toIfaceTyCon tc)
(toIfaceTcArgs tc ty)
(tidyToIfaceTcArgs tc_env1 tc ty)
Nothing -> IfNoParent
to_ifsyn_rhs OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon
to_ifsyn_rhs (ClosedSynFamilyTyCon ax) = IfaceClosedSynFamilyTyCon axn ibr
where defs = fromBranchList $ coAxiomBranches ax
ibr = map coAxBranchToIfaceBranch' defs
ibr = map (coAxBranchToIfaceBranch' tycon) defs
axn = coAxiomName ax
to_ifsyn_rhs AbstractClosedSynFamilyTyCon
= IfaceAbstractClosedSynFamilyTyCon
to_ifsyn_rhs (SynonymTyCon ty)
= IfaceSynonymTyCon (tidyToIfaceType env1 ty)
= IfaceSynonymTyCon (tidyToIfaceType tc_env1 ty)
to_ifsyn_rhs (BuiltInSynFamTyCon {})
= IfaceBuiltInSynFamTyCon
......@@ -1649,22 +1650,29 @@ tyConToIfaceDecl env tycon
= IfCon { ifConOcc = getOccName (dataConName data_con),
ifConInfix = dataConIsInfix data_con,
ifConWrapper = isJust (dataConWrapId_maybe data_con),
ifConUnivTvs = toIfaceTvBndrs univ_tvs',
ifConUnivTvs = if_tc_tyvars,
ifConExTvs = toIfaceTvBndrs ex_tvs',
ifConEqSpec = map to_eq_spec eq_spec,
ifConCtxt = tidyToIfaceContext env2 theta,
ifConArgTys = map (tidyToIfaceType env2) arg_tys,
ifConCtxt = tidyToIfaceContext con_env2 theta,
ifConArgTys = map (tidyToIfaceType con_env2) arg_tys,
ifConFields = map getOccName
(dataConFieldLabels data_con),
ifConStricts = map (toIfaceBang env2) (dataConRepBangs data_con) }
ifConStricts = map (toIfaceBang con_env2) (dataConRepBangs data_con) }
where
(univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
-- Start with 'emptyTidyEnv' not 'env1', because the type of the
-- data constructor is fully standalone
(env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs
(env2, ex_tvs') = tidyTyVarBndrs env1 ex_tvs
to_eq_spec (tv,ty) = (toIfaceTyVar (tidyTyVar env2 tv), tidyToIfaceType env2 ty)
-- Tidy the univ_tvs of the data constructor to be identical
-- to the tyConTyVars of the type constructor. This means
-- (a) we don't need to redundantly put them into the interface file
-- (b) when pretty-printing an Iface data declaration in H98-style syntax,
-- we know that the type variables will line up
-- The latter (b) is important because we pretty-print type construtors
-- by converting to IfaceSyn and pretty-printing that
con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))
-- A bit grimy, perhaps, but it's simple!
(con_env2, ex_tvs') = tidyTyVarBndrs con_env1 ex_tvs
to_eq_spec (tv,ty) = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
toIfaceBang :: TidyEnv -> HsBang -> IfaceBang
toIfaceBang _ HsNoBang = IfNoBang
......@@ -1693,7 +1701,7 @@ classToIfaceDecl env clas
toIfaceAT :: ClassATItem -> IfaceAT
toIfaceAT (tc, defs)
= IfaceAT (tyConToIfaceDecl env1 tc) (map coAxBranchToIfaceBranch' defs)
= IfaceAT (tyConToIfaceDecl env1 tc) (map (coAxBranchToIfaceBranch' tc) defs)
toIfaceClassOp (sel_id, def_meth)
= ASSERT(sel_tyvars == clas_tyvars)
......@@ -1719,11 +1727,8 @@ classToIfaceDecl env clas
tidyToIfaceType :: TidyEnv -> Type -> IfaceType
tidyToIfaceType env ty = toIfaceType (tidyType env ty)
tidyToIfaceTcArgs :: TidyEnv -> [Type] -> IfaceTcArgs
tidyToIfaceTcArgs _ [] = ITC_Nil
tidyToIfaceTcArgs env (t:ts)
| isKind t = ITC_Kind (tidyToIfaceType env t) (tidyToIfaceTcArgs env ts)
| otherwise = ITC_Type (tidyToIfaceType env t) (tidyToIfaceTcArgs env ts)
tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceTcArgs
tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys)
tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext
tidyToIfaceContext env theta = map (tidyToIfaceType env) theta
......
type role Equal nominal nominal
data Equal a b where
Equal :: Equal a1 a1
-- Defined at T4087.hs:5:1
type role Equal nominal nominal
data Equal a b where
Equal :: Equal b b
-- Defined at T4087.hs:5:1
T7438.hs:6:14:
Couldn't match expected type ‘t1’ with actual type ‘t’
‘t’ is untouchable
inside the constraints (t2 ~ t3)
bound by a pattern with constructor
Nil :: forall (k :: BOX) (a :: k). Thrist a a,
in an equation for ‘go’
at T7438.hs:6:4-6
‘t’ is a rigid type variable bound by
the inferred type of go :: Thrist t2 t3 -> t -> t1 at T7438.hs:6:1
‘t1’ is a rigid type variable bound by
the inferred type of go :: Thrist t2 t3 -> t -> t1 at T7438.hs:6:1
Possible fix: add a type signature for ‘go’
Relevant bindings include
acc :: t (bound at T7438.hs:6:8)
go :: Thrist t2 t3 -> t -> t1 (bound at T7438.hs:6:1)
In the expression: acc
In an equation for ‘go’: go Nil acc = acc
T7438.hs:6:14:
Couldn't match expected type ‘t1’ with actual type ‘t’
‘t’ is untouchable
inside the constraints (t2 ~ t3)
bound by a pattern with constructor
Nil :: forall (k :: BOX) (b :: k). Thrist b b,
in an equation for ‘go’
at T7438.hs:6:4-6
‘t’ is a rigid type variable bound by
the inferred type of go :: Thrist t2 t3 -> t -> t1 at T7438.hs:6:1
‘t1’ is a rigid type variable bound by
the inferred type of go :: Thrist t2 t3 -> t -> t1 at T7438.hs:6:1
Possible fix: add a type signature for ‘go’
Relevant bindings include
acc :: t (bound at T7438.hs:6:8)
go :: Thrist t2 t3 -> t -> t1 (bound at T7438.hs:6:1)
In the expression: acc
In an equation for ‘go’: go Nil acc = acc
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment