Commit e368f326 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Major patch to introduce TyConBinder

Before this patch, following the TypeInType innovations,
each TyCon had two lists:
  - tyConBinders :: [TyBinder]
  - tyConTyVars  :: [TyVar]

They were in 1-1 correspondence and contained
overlapping information.  More broadly, there were many
places where we had to pass around this pair of lists,
instead of a single list.

This commit tidies all that up, by having just one list of
binders in a TyCon:

  - tyConBinders :: [TyConBinder]

The new data types look like this:

  Var.hs:
     data TyVarBndr tyvar vis = TvBndr tyvar vis
     data VisibilityFlag = Visible | Specified | Invisible
     type TyVarBinder = TyVarBndr TyVar VisibilityFlag

  TyCon.hs:
     type TyConBinder = TyVarBndr TyVar TyConBndrVis

     data TyConBndrVis
       = NamedTCB VisibilityFlag
       | AnonTCB

  TyCoRep.hs:
     data TyBinder
       = Named TyVarBinder
       | Anon Type

Note that Var.TyVarBdr has moved from TyCoRep and has been
made polymorphic in the tyvar and visiblity fields:

     type TyVarBinder = TyVarBndr TyVar VisibilityFlag
        -- Used in ForAllTy
     type TyConBinder = TyVarBndr TyVar TyConBndrVis
        -- Used in TyCon

     type IfaceForAllBndr  = TyVarBndr IfaceTvBndr VisibilityFlag
     type IfaceTyConBinder = TyVarBndr IfaceTvBndr TyConBndrVis
         -- Ditto, in interface files

There are a zillion knock-on changes, but everything
arises from these types.  It was a bit fiddly to get the
module loops to work out right!

Some smaller points
~~~~~~~~~~~~~~~~~~~
* Nice new functions
    TysPrim.mkTemplateKiTyVars
    TysPrim.mkTemplateTyConBinders
  which help you make the tyvar binders for dependently-typed
  TyCons.  See comments with their definition.

* The change showed up a bug in TcGenGenerics.tc_mkRepTy, where the code
  was making an assumption about the order of the kind variables in the
  kind of GHC.Generics.(:.:).  I fixed this; see TcGenGenerics.mkComp.
parent 77bb0927
......@@ -77,7 +77,9 @@ import BasicTypes
import FastString
import Module
import Binary
import UniqSet
import UniqFM
import Unique( mkAlphaTyVarUnique )
import qualified Data.Data as Data
import Data.Char
......@@ -797,20 +799,50 @@ mkDataCon name declared_infix prom_info
rep_ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $
mkFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys (map binderVar univ_tvs))
mkTyConApp rep_tycon (mkTyVarTys (binderVars univ_tvs))
-- See Note [Promoted data constructors] in TyCon
prom_binders = map mkNamedBinder (filterEqSpec eq_spec univ_tvs) ++
map mkNamedBinder ex_tvs ++
map mkAnonBinder theta ++
map mkAnonBinder orig_arg_tys
prom_res_kind = orig_res_ty
promoted = mkPromotedDataCon con name prom_info prom_binders
prom_res_kind roles rep_info
prom_tv_bndrs = [ mkNamedTyConBinder vis tv
| TvBndr tv vis <- filterEqSpec eq_spec univ_tvs ++ ex_tvs ]
prom_arg_bndrs = mkCleanAnonTyConBinders prom_tv_bndrs (theta ++ orig_arg_tys)
prom_res_kind = orig_res_ty
promoted = mkPromotedDataCon con name prom_info
(prom_tv_bndrs ++ prom_arg_bndrs)
prom_res_kind roles rep_info
roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++
map (const Representational) orig_arg_tys
mkCleanAnonTyConBinders :: [TyConBinder] -> [Type] -> [TyConBinder]
-- Make sure that the "anonymous" tyvars don't clash in
-- name or unique with the universal/existential ones.
-- Tiresome! And unnecessary because these tyvars are never looked at
mkCleanAnonTyConBinders tc_bndrs tys
= [ mkAnonTyConBinder (mkTyVar name ty)
| (name, ty) <- fresh_names `zip` tys ]
where
fresh_names = freshNames (map getName (binderVars tc_bndrs))
freshNames :: [Name] -> [Name]
-- Make names whose Uniques and OccNames differ from
-- those in the 'avoid' list
freshNames avoids
= [ mkSystemName uniq occ
| n <- [0..]
, let uniq = mkAlphaTyVarUnique n
occ = mkTyVarOccFS (mkFastString ('x' : show n))
, not (uniq `elementOfUniqSet` avoid_uniqs)
, not (occ `elemOccSet` avoid_occs) ]
where
avoid_uniqs :: UniqSet Unique
avoid_uniqs = mkUniqSet (map getUnique avoids)
avoid_occs :: OccSet
avoid_occs = mkOccSet (map getOccName avoids)
-- | The 'Name' of the 'DataCon', giving it a unique, rooted identification
dataConName :: DataCon -> Name
dataConName = dcName
......@@ -842,7 +874,7 @@ dataConIsInfix = dcInfix
-- | The universally-quantified type variables of the constructor
dataConUnivTyVars :: DataCon -> [TyVar]
dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = map binderVar tvbs
dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = binderVars tvbs
-- | 'TyBinder's for the universally-quantified type variables
dataConUnivTyVarBinders :: DataCon -> [TyVarBinder]
......@@ -850,7 +882,7 @@ dataConUnivTyVarBinders = dcUnivTyVars
-- | The existentially-quantified type variables of the constructor
dataConExTyVars :: DataCon -> [TyVar]
dataConExTyVars (MkData { dcExTyVars = tvbs }) = map binderVar tvbs
dataConExTyVars (MkData { dcExTyVars = tvbs }) = binderVars tvbs
-- | 'TyBinder's for the existentially-quantified type variables
dataConExTyVarBinders :: DataCon -> [TyVarBinder]
......@@ -859,7 +891,7 @@ dataConExTyVarBinders = dcExTyVars
-- | Both the universal and existentiatial type variables of the constructor
dataConAllTyVars :: DataCon -> [TyVar]
dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs })
= map binderVar (univ_tvs ++ ex_tvs)
= binderVars (univ_tvs ++ ex_tvs)
-- | Equalities derived from the result type of the data constructor, as written
-- by the programmer in any GADT declaration. This includes *all* GADT-like
......@@ -1014,9 +1046,9 @@ dataConInstSig (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs
, substTheta subst (eqSpecPreds eq_spec ++ theta)
, substTys subst arg_tys)
where
univ_subst = zipTvSubst (map binderVar univ_tvs) univ_tys
univ_subst = zipTvSubst (binderVars univ_tvs) univ_tys
(subst, ex_tvs') = mapAccumL Type.substTyVarBndr univ_subst $
map binderVar ex_tvs
binderVars ex_tvs
-- | The \"full signature\" of the 'DataCon' returns, in order:
......@@ -1038,7 +1070,7 @@ dataConFullSig :: DataCon
dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
dcEqSpec = eq_spec, dcOtherTheta = theta,
dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
= (map binderVar univ_tvs, map binderVar ex_tvs, eq_spec, theta, arg_tys, res_ty)
= (binderVars univ_tvs, binderVars ex_tvs, eq_spec, theta, arg_tys, res_ty)
dataConOrigResTy :: DataCon -> Type
dataConOrigResTy dc = dcOrigResTy dc
......@@ -1086,7 +1118,7 @@ dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs,
= ASSERT2( length univ_tvs == length inst_tys
, text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)
ASSERT2( null ex_tvs, ppr dc )
map (substTyWith (map binderVar univ_tvs) inst_tys) (dataConRepArgTys dc)
map (substTyWith (binderVars univ_tvs) inst_tys) (dataConRepArgTys dc)
-- | Returns just the instantiated /value/ argument types of a 'DataCon',
-- (excluding dictionary args)
......@@ -1104,7 +1136,7 @@ dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
, text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys )
map (substTyWith tyvars inst_tys) arg_tys
where
tyvars = map binderVar (univ_tvs ++ ex_tvs)
tyvars = binderVars (univ_tvs ++ ex_tvs)
-- | Returns the argument types of the wrapper, excluding all dictionary arguments
-- and without substituting for any type variables
......@@ -1265,7 +1297,7 @@ buildAlgTyCon :: Name
buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
is_rec gadt_syn parent
= mkAlgTyCon tc_name binders liftedTypeKind ktvs roles cType stupid_theta
= mkAlgTyCon tc_name binders liftedTypeKind roles cType stupid_theta
rhs parent is_rec gadt_syn
where
binders = mkTyBindersPreferAnon ktvs liftedTypeKind
binders = mkTyConBindersPreferAnon ktvs liftedTypeKind
module DataCon where
import Var( TyVar )
import Var( TyVar, TyVarBinder )
import Name( Name, NamedThing )
import {-# SOURCE #-} TyCon( TyCon )
import FieldLabel ( FieldLabel )
import Unique ( Uniquable )
import Outputable ( Outputable, OutputableBndr )
import BasicTypes (Arity)
import {-# SOURCE #-} TyCoRep (Type, ThetaType, TyVarBinder)
import {-# SOURCE #-} TyCoRep ( Type, ThetaType )
data DataCon
data DataConRep
......
......@@ -280,7 +280,7 @@ mkDictSelId name clas
val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name
sel_ty = mkForAllTys tyvars $
mkFunTy (mkClassPred clas (mkTyVarTys (map binderVar tyvars))) $
mkFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $
getNth arg_tys val_index
base_info = noCafIdInfo
......@@ -1066,22 +1066,17 @@ dollarId = pcMiscPrelId dollarName ty
App (Var f) (Var x)
------------------------------------------------
-- proxy# :: forall a. Proxy# a
proxyHashId :: Id
proxyHashId
= pcMiscPrelId proxyName ty
(noCafIdInfo `setUnfoldingInfo` evaldUnfolding) -- Note [evaldUnfoldings]
where
ty = mkSpecForAllTys [kv, tv] (mkProxyPrimTy k t)
kv = kKiVar
k = mkTyVarTy kv
[tv] = mkTemplateTyVars [k]
t = mkTyVarTy tv
-- proxy# :: forall k (a:k). Proxy# k a
bndrs = mkTemplateKiTyVars [liftedTypeKind] (\ks -> ks)
[k,t] = mkTyVarTys bndrs
ty = mkSpecForAllTys bndrs (mkProxyPrimTy k t)
------------------------------------------------
-- unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
-- (a :: TYPE r1) (b :: TYPE r2).
-- a -> b
unsafeCoerceId :: Id
unsafeCoerceId
= pcMiscPrelId unsafeCoerceName ty info
......@@ -1089,14 +1084,19 @@ unsafeCoerceId
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` mkCompulsoryUnfolding rhs
tvs = [ runtimeRep1TyVar, runtimeRep2TyVar
, openAlphaTyVar, openBetaTyVar ]
-- unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
-- (a :: TYPE r1) (b :: TYPE r2).
-- a -> b
bndrs = mkTemplateKiTyVars [runtimeRepTy, runtimeRepTy]
(\ks -> map tYPE ks)
ty = mkSpecForAllTys tvs $ mkFunTy openAlphaTy openBetaTy
[_, _, a, b] = mkTyVarTys bndrs
[x] = mkTemplateLocals [openAlphaTy]
rhs = mkLams (tvs ++ [x]) $
Cast (Var x) (mkUnsafeCo Representational openAlphaTy openBetaTy)
ty = mkSpecForAllTys bndrs (mkFunTy a b)
[x] = mkTemplateLocals [a]
rhs = mkLams (bndrs ++ [x]) $
Cast (Var x) (mkUnsafeCo Representational a b)
------------------------------------------------
nullAddrId :: Id
......
......@@ -359,7 +359,7 @@ patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder]
patSynUnivTyVarBinders = psUnivTyVars
patSynExTyVars :: PatSyn -> [TyVar]
patSynExTyVars ps = map binderVar (psExTyVars ps)
patSynExTyVars ps = binderVars (psExTyVars ps)
patSynExTyVarBinders :: PatSyn -> [TyVarBinder]
patSynExTyVarBinders = psExTyVars
......@@ -368,7 +368,7 @@ patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type)
patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
, psProvTheta = prov, psReqTheta = req
, psArgs = arg_tys, psOrigResTy = res_ty })
= (map binderVar univ_tvs, req, map binderVar ex_tvs, prov, arg_tys, res_ty)
= (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty)
patSynMatcher :: PatSyn -> (Id,Bool)
patSynMatcher = psMatcher
......@@ -397,7 +397,7 @@ patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
, text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys )
map (substTyWith tyvars inst_tys) arg_tys
where
tyvars = map binderVar (univ_tvs ++ ex_tvs)
tyvars = binderVars (univ_tvs ++ ex_tvs)
patSynInstResTy :: PatSyn -> [Type] -> Type
-- Return the type of whole pattern
......@@ -410,7 +410,7 @@ patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
inst_tys
= ASSERT2( length univ_tvs == length inst_tys
, text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
substTyWith (map binderVar univ_tvs) inst_tys res_ty
substTyWith (binderVars univ_tvs) inst_tys res_ty
-- | Print the type of a pattern synonym. The foralls are printed explicitly
pprPatSynType :: PatSyn -> SDoc
......
......@@ -5,7 +5,7 @@
\section{@Vars@: Variables}
-}
{-# LANGUAGE CPP, MultiWayIf #-}
{-# LANGUAGE CPP, MultiWayIf, FlexibleInstances, DeriveDataTypeable #-}
-- |
-- #name_types#
......@@ -56,7 +56,12 @@ module Var (
isGlobalId, isExportedId,
mustHaveLocalBinding,
-- ** Constructing 'TyVar's
-- * TyVar's
TyVarBndr(..), VisibilityFlag(..), TyVarBinder,
binderVar, binderVars, binderVisibility, binderKind,
isVisible, isInvisible, sameVis,
-- ** Constructing TyVar's
mkTyVar, mkTcTyVar,
-- ** Taking 'TyVar's apart
......@@ -77,12 +82,13 @@ import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolem
import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, isCoVarDetails, vanillaIdInfo, pprIdDetails )
import Name hiding (varName)
import Unique
import Unique ( Uniquable, Unique, getKey, getUnique
, mkUniqueGrimily, nonDetCmpUnique )
import Util
import Binary
import DynFlags
import Outputable
import Unique (nonDetCmpUnique)
import Data.Data
{-
......@@ -309,10 +315,69 @@ updateVarTypeM :: Monad m => (Type -> m Type) -> Id -> m Id
updateVarTypeM f id = do { ty' <- f (varType id)
; return (id { varType = ty' }) }
{- *********************************************************************
* *
* VisibilityFlag
* *
********************************************************************* -}
-- | Is something required to appear in source Haskell ('Visible'),
-- permitted by request ('Specified') (visible type application), or
-- prohibited entirely from appearing in source Haskell ('Invisible')?
-- See Note [TyBinders and VisibilityFlags] in TyCoRep
data VisibilityFlag = Visible | Specified | Invisible
deriving (Eq, Data)
isVisible :: VisibilityFlag -> Bool
isVisible Visible = True
isVisible _ = False
isInvisible :: VisibilityFlag -> Bool
isInvisible v = not (isVisible v)
-- | Do these denote the same level of visibility? Except that
-- 'Specified' and 'Invisible' are considered the same. Used
-- for printing.
sameVis :: VisibilityFlag -> VisibilityFlag -> Bool
sameVis Visible Visible = True
sameVis Visible _ = False
sameVis _ Visible = False
sameVis _ _ = True
{- *********************************************************************
* *
* TyVarBndr, TyVarBinder
* *
********************************************************************* -}
-- TyVarBndr is polymorphic in both tyvar and visiblity fields:
-- * tyvar can be TyVar or IfaceTv
-- * vis can be VisibilityFlag or TyConBndrVis
data TyVarBndr tyvar vis = TvBndr tyvar vis
deriving( Data )
-- | A `TyVarBinder` is the binder of a ForAllTy
-- It's convenient to define this synonym here rather its natural
-- home in TyCoRep, because it's used in DataCon.hs-boot
type TyVarBinder = TyVarBndr TyVar VisibilityFlag
binderVar :: TyVarBndr tv vis -> tv
binderVar (TvBndr v _) = v
binderVars :: [TyVarBndr tv vis] -> [tv]
binderVars tvbs = map binderVar tvbs
binderVisibility :: TyVarBndr tv vis -> vis
binderVisibility (TvBndr _ vis) = vis
binderKind :: TyVarBndr TyVar vis -> Kind
binderKind (TvBndr tv _) = tyVarKind tv
{-
************************************************************************
* *
\subsection{Type and kind variables}
* Type and kind variables *
* *
************************************************************************
-}
......@@ -363,6 +428,35 @@ tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind (
setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar
setTcTyVarDetails tv details = tv { tc_tv_details = details }
-------------------------------------
instance Outputable tv => Outputable (TyVarBndr tv VisibilityFlag) where
ppr (TvBndr v Visible) = ppr v
ppr (TvBndr v Specified) = char '@' <> ppr v
ppr (TvBndr v Invisible) = braces (ppr v)
instance Outputable VisibilityFlag where
ppr Visible = text "[vis]"
ppr Specified = text "[spec]"
ppr Invisible = text "[invis]"
instance (Binary tv, Binary vis) => Binary (TyVarBndr tv vis) where
put_ bh (TvBndr tv vis) = do { put_ bh tv; put_ bh vis }
get bh = do { tv <- get bh; vis <- get bh; return (TvBndr tv vis) }
instance Binary VisibilityFlag where
put_ bh Visible = putByte bh 0
put_ bh Specified = putByte bh 1
put_ bh Invisible = putByte bh 2
get bh = do
h <- getByte bh
case h of
0 -> return Visible
1 -> return Specified
_ -> return Invisible
{-
%************************************************************************
%* *
......
......@@ -352,7 +352,7 @@ orphNamesOfType (TyVarTy _) = emptyNameSet
orphNamesOfType (LitTy {}) = emptyNameSet
orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon
`unionNameSet` orphNamesOfTypes tys
orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr)
orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderKind bndr)
`unionNameSet` orphNamesOfType res
orphNamesOfType (FunTy arg res) = unitNameSet funTyConName -- NB! See Trac #8535
`unionNameSet` orphNamesOfType arg
......
......@@ -6,7 +6,7 @@
{-# LANGUAGE CPP #-}
module BuildTyCl (
buildDataCon,
buildDataCon, mkDataConUnivTyVarBinders,
buildPatSyn,
TcMethInfo, buildClass,
distinctAbstractTyConRhs, totallyAbstractTyConRhs,
......@@ -29,7 +29,6 @@ import MkId
import Class
import TyCon
import Type
import TyCoRep( TyBinder(..), TyVarBinder(..) )
import Id
import TcType
......@@ -112,8 +111,8 @@ buildDataCon :: FamInstEnvs
-> Maybe [HsImplBang]
-- See Note [Bangs on imported data constructors] in MkId
-> [FieldLabel] -- Field labels
-> [TyVar] -> [TyBinder] -- Universals
-> [TyVarBinder] -- existentials
-> [TyVarBinder] -- Universals
-> [TyVarBinder] -- Existentials
-> [EqSpec] -- Equality spec
-> ThetaType -- Does not include the "stupid theta"
-- or the GADT equalities
......@@ -126,7 +125,7 @@ buildDataCon :: FamInstEnvs
-- allocating its unique (hence monadic)
-- c) Sorts out the TyVarBinders. See mkDataConUnivTyBinders
buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls
univ_tvs univ_bndrs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
= do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
-- This last one takes the name of the data constructor in the source
......@@ -136,11 +135,10 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie
; traceIf (text "buildDataCon 1" <+> ppr src_name)
; us <- newUniqueSupply
; dflags <- getDynFlags
; let dc_bndrs = mkDataConUnivTyVarBinders univ_tvs univ_bndrs
stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
data_con = mkDataCon src_name declared_infix prom_info
src_bangs field_lbls
dc_bndrs ex_tvs eq_spec ctxt
univ_tvs ex_tvs eq_spec ctxt
arg_tys res_ty NoRRI rep_tycon
stupid_ctxt dc_wrk dc_rep
dc_wrk = mkDataConWorkId work_name data_con
......@@ -155,12 +153,13 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie
-- the type variables mentioned in the arg_tys
-- ToDo: Or functionally dependent on?
-- This whole stupid theta thing is, well, stupid.
mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]
mkDataConStupidTheta :: TyCon -> [Type] -> [TyVarBinder] -> [PredType]
mkDataConStupidTheta tycon arg_tys univ_tvs
| null stupid_theta = [] -- The common case
| otherwise = filter in_arg_tys stupid_theta
where
tc_subst = zipTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
tc_subst = zipTvSubst (tyConTyVars tycon)
(mkTyVarTys (binderVars univ_tvs))
stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
-- Start by instantiating the master copy of the
-- stupid theta, taken from the TyCon
......@@ -170,18 +169,18 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
tyCoVarsOfType pred `intersectVarSet` arg_tyvars
mkDataConUnivTyVarBinders :: [TyVar] -> [TyBinder] -- From the TyCon
-> [TyVarBinder] -- For the DataCon
mkDataConUnivTyVarBinders :: [TyConBinder] -- From the TyCon
-> [TyVarBinder] -- For the DataCon
-- See Note [Building the TyBinders for a DataCon]
mkDataConUnivTyVarBinders tvs bndrs
= zipWith mk_binder tvs bndrs
mkDataConUnivTyVarBinders tc_bndrs
= map mk_binder tc_bndrs
where
mk_binder tv bndr = mkTyVarBinder vis tv
mk_binder (TvBndr tv tc_vis) = mkTyVarBinder vis tv
where
vis = case bndr of
Anon _ -> Specified
Named (TvBndr _ Visible) -> Specified
Named (TvBndr _ vis) -> vis
vis = case tc_vis of
AnonTCB -> Specified
NamedTCB Visible -> Specified
NamedTCB vis -> vis
{- Note [Building the TyBinders for a DataCon]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -272,7 +271,7 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
(arg_tys1, _) = tcSplitFunTys cont_tau
twiddle = char '~'
subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)
(mkTyVarTys (map binderVar (univ_tvs ++ ex_tvs)))
(mkTyVarTys (binderVars (univ_tvs ++ ex_tvs)))
------------------------------------------------------
type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
......@@ -280,8 +279,8 @@ type TcMethInfo = (Name, Type, Maybe (DefMethSpec Type))
-- tcClassSigs and buildClass.
buildClass :: Name -- Name of the class/tycon (they have the same Name)
-> [TyVar] -> [Role] -> ThetaType
-> [TyBinder] -- of the tycon
-> [TyConBinder] -- Of the tycon
-> [Role] -> ThetaType
-> [FunDep TyVar] -- Functional dependencies
-> [ClassATItem] -- Associated types
-> [TcMethInfo] -- Method info
......@@ -289,7 +288,7 @@ buildClass :: Name -- Name of the class/tycon (they have the same Name)
-> RecFlag -- Info for type constructor
-> TcRnIf m n Class
buildClass tycon_name tvs roles sc_theta binders
buildClass tycon_name binders roles sc_theta
fds at_items sig_stuff mindef tc_isrec
= fixM $ \ rec_clas -> -- Only name generation inside loop
do { traceIf (text "buildClass")
......@@ -325,11 +324,13 @@ buildClass tycon_name tvs roles sc_theta binders
-- That means that in the case of
-- class C a => D a
-- we don't get a newtype with no arguments!
args = sc_sel_names ++ op_names
op_tys = [ty | (_,ty,_) <- sig_stuff]
op_names = [op | (op,_,_) <- sig_stuff]
arg_tys = sc_theta ++ op_tys
rec_tycon = classTyCon rec_clas
args = sc_sel_names ++ op_names
op_tys = [ty | (_,ty,_) <- sig_stuff]
op_names = [op | (op,_,_) <- sig_stuff]
arg_tys = sc_theta ++ op_tys
rec_tycon = classTyCon rec_clas
univ_bndrs = mkDataConUnivTyVarBinders binders
univ_tvs = binderVars univ_bndrs
; rep_nm <- newTyConRepName datacon_name
; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
......@@ -339,12 +340,12 @@ buildClass tycon_name tvs roles sc_theta binders
(map (const no_bang) args)
(Just (map (const HsLazy) args))
[{- No fields -}]
tvs binders
univ_bndrs
[{- no existentials -}]
[{- No GADT equalities -}]
[{- No theta -}]
arg_tys
(mkTyConApp rec_tycon (mkTyVarTys tvs))
(mkTyConApp rec_tycon (mkTyVarTys univ_tvs))
rec_tycon
; rhs <- if use_newtype
......@@ -354,7 +355,7 @@ buildClass tycon_name tvs roles sc_theta binders
, tup_sort = ConstraintTuple })
else return (mkDataTyConRhs [dict_con])
; let { tycon = mkClassTyCon tycon_name binders tvs roles
; let { tycon = mkClassTyCon tycon_name binders roles
rhs rec_clas tc_isrec tc_rep_name
-- A class can be recursive, and in the case of newtypes
-- this matters. For example
......@@ -365,7 +366,7 @@ buildClass tycon_name tvs roles sc_theta binders
-- newtype like a synonym, but that will lead to an infinite
-- type]
; result = mkClass tvs fds
; result = mkClass tycon_name univ_tvs fds
sc_theta sc_sel_ids at_items
op_items mindef tycon
}
......
......@@ -57,6 +57,7 @@ import SrcLoc
import Fingerprint
import Binary
import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )
import Var( TyVarBndr(..) )
import TyCon ( Role (..), Injectivity(..) )
import StaticFlags (opt_PprStyle_Debug)
import Util( filterOut, filterByList )
......@@ -972,7 +973,7 @@ ppr_rough Nothing = dot
ppr_rough (Just tc) = ppr tc
tv_to_forall_bndr :: IfaceTvBndr -> IfaceForAllBndr
tv_to_forall_bndr tv =