ghc-lib-8.8.2: compiler/iface/BuildTyCl.hs
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}
{-# LANGUAGE CPP #-}
module BuildTyCl (
buildDataCon,
buildPatSyn,
TcMethInfo, MethInfo, buildClass,
mkNewTyConRhs,
newImplicitBinder, newTyConRepName
) where
#include "HsVersions.h"
import GhcPrelude
import IfaceEnv
import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )
import TysWiredIn( isCTupleTyConName )
import TysPrim ( voidPrimTy )
import DataCon
import PatSyn
import Var
import VarSet
import BasicTypes
import Name
import NameEnv
import MkId
import Class
import TyCon
import Type
import Id
import TcType
import SrcLoc( SrcSpan, noSrcSpan )
import DynFlags
import TcRnMonad
import UniqSupply
import Util
import Outputable
mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
-- ^ Monadic because it makes a Name for the coercion TyCon
-- We pass the Name of the parent TyCon, as well as the TyCon itself,
-- because the latter is part of a knot, whereas the former is not.
mkNewTyConRhs tycon_name tycon con
= do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs
; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax)
; return (NewTyCon { data_con = con,
nt_rhs = rhs_ty,
nt_etad_rhs = (etad_tvs, etad_rhs),
nt_co = nt_ax } ) }
-- Coreview looks through newtypes with a Nothing
-- for nt_co, or uses explicit coercions otherwise
where
tvs = tyConTyVars tycon
roles = tyConRoles tycon
con_arg_ty = case dataConRepArgTys con of
[arg_ty] -> arg_ty
tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys)
rhs_ty = substTyWith (dataConUnivTyVars con)
(mkTyVarTys tvs) con_arg_ty
-- Instantiate the newtype's RHS with the
-- type variables from the tycon
-- NB: a newtype DataCon has a type that must look like
-- forall tvs. <arg-ty> -> T tvs
-- Note that we *can't* use dataConInstOrigArgTys here because
-- the newtype arising from class Foo a => Bar a where {}
-- has a single argument (Foo a) that is a *type class*, so
-- dataConInstOrigArgTys returns [].
etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can
etad_roles :: [Role] -- return a TyCon without pulling on rhs_ty
etad_rhs :: Type -- See Note [Tricky iface loop] in LoadIface
(etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty
eta_reduce :: [TyVar] -- Reversed
-> [Role] -- also reversed
-> Type -- Rhs type
-> ([TyVar], [Role], Type) -- Eta-reduced version
-- (tyvars in normal order)
eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,
Just tv <- getTyVar_maybe arg,
tv == a,
not (a `elemVarSet` tyCoVarsOfType fun)
= eta_reduce as rs fun
eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)
------------------------------------------------------
buildDataCon :: FamInstEnvs
-> Name
-> Bool -- Declared infix
-> TyConRepName
-> [HsSrcBang]
-> Maybe [HsImplBang]
-- See Note [Bangs on imported data constructors] in MkId
-> [FieldLabel] -- Field labels
-> [TyVar] -- Universals
-> [TyCoVar] -- Existentials
-> [TyVarBinder] -- User-written 'TyVarBinder's
-> [EqSpec] -- Equality spec
-> KnotTied ThetaType -- Does not include the "stupid theta"
-- or the GADT equalities
-> [KnotTied Type] -- Arguments
-> KnotTied Type -- Result types
-> KnotTied TyCon -- Rep tycon
-> NameEnv ConTag -- Maps the Name of each DataCon to its
-- ConTag
-> TcRnIf m n DataCon
-- A wrapper for DataCon.mkDataCon that
-- a) makes the worker Id
-- b) makes the wrapper Id if necessary, including
-- allocating its unique (hence monadic)
buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs
field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty
rep_tycon tag_map
= 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
-- code, which (for Haskell source anyway) will be in the DataName name
-- space, and puts it into the VarName name space
; traceIf (text "buildDataCon 1" <+> ppr src_name)
; us <- newUniqueSupply
; dflags <- getDynFlags
; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
tag = lookupNameEnv_NF tag_map src_name
-- See Note [Constructor tag allocation], fixes #14657
data_con = mkDataCon src_name declared_infix prom_info
src_bangs field_lbls
univ_tvs ex_tvs user_tvbs eq_spec ctxt
arg_tys res_ty NoRRI rep_tycon tag
stupid_ctxt dc_wrk dc_rep
dc_wrk = mkDataConWorkId work_name data_con
dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
impl_bangs data_con)
; traceIf (text "buildDataCon 2" <+> ppr src_name)
; return data_con }
-- The stupid context for a data constructor should be limited to
-- 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 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)
stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)
-- Start by instantiating the master copy of the
-- stupid theta, taken from the TyCon
arg_tyvars = tyCoVarsOfTypes arg_tys
in_arg_tys pred = not $ isEmptyVarSet $
tyCoVarsOfType pred `intersectVarSet` arg_tyvars
------------------------------------------------------
buildPatSyn :: Name -> Bool
-> (Id,Bool) -> Maybe (Id, Bool)
-> ([TyVarBinder], ThetaType) -- ^ Univ and req
-> ([TyVarBinder], ThetaType) -- ^ Ex and prov
-> [Type] -- ^ Argument types
-> Type -- ^ Result type
-> [FieldLabel] -- ^ Field labels for
-- a record pattern synonym
-> PatSyn
buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
(univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys
pat_ty field_labels
= -- The assertion checks that the matcher is
-- compatible with the pattern synonym
ASSERT2((and [ univ_tvs `equalLength` univ_tvs1
, ex_tvs `equalLength` ex_tvs1
, pat_ty `eqType` substTy subst pat_ty1
, prov_theta `eqTypes` substTys subst prov_theta1
, req_theta `eqTypes` substTys subst req_theta1
, compareArgTys arg_tys (substTys subst arg_tys1)
])
, (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1
, ppr ex_tvs <+> twiddle <+> ppr ex_tvs1
, ppr pat_ty <+> twiddle <+> ppr pat_ty1
, ppr prov_theta <+> twiddle <+> ppr prov_theta1
, ppr req_theta <+> twiddle <+> ppr req_theta1
, ppr arg_tys <+> twiddle <+> ppr arg_tys1]))
mkPatSyn src_name declared_infix
(univ_tvs, req_theta) (ex_tvs, prov_theta)
arg_tys pat_ty
matcher builder field_labels
where
((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id
([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau
(ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy cont_sigma
(arg_tys1, _) = (tcSplitFunTys cont_tau)
twiddle = char '~'
subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)
(mkTyVarTys (binderVars (univ_tvs ++ ex_tvs)))
-- For a nullary pattern synonym we add a single void argument to the
-- matcher to preserve laziness in the case of unlifted types.
-- See #12746
compareArgTys :: [Type] -> [Type] -> Bool
compareArgTys [] [x] = x `eqType` voidPrimTy
compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys
------------------------------------------------------
type TcMethInfo = MethInfo -- this variant needs zonking
type MethInfo -- A temporary intermediate, to communicate
-- between tcClassSigs and buildClass.
= ( Name -- Name of the class op
, Type -- Type of the class op
, Maybe (DefMethSpec (SrcSpan, Type)))
-- Nothing => no default method
--
-- Just VanillaDM => There is an ordinary
-- polymorphic default method
--
-- Just (GenericDM (loc, ty)) => There is a generic default metho
-- Here is its type, and the location
-- of the type signature
-- We need that location /only/ to attach it to the
-- generic default method's Name; and we need /that/
-- only to give the right location of an ambiguity error
-- for the generic default method, spat out by checkValidClass
buildClass :: Name -- Name of the class/tycon (they have the same Name)
-> [TyConBinder] -- Of the tycon
-> [Role]
-> [FunDep TyVar] -- Functional dependencies
-- Super classes, associated types, method info, minimal complete def.
-- This is Nothing if the class is abstract.
-> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef)
-> TcRnIf m n Class
buildClass tycon_name binders roles fds Nothing
= fixM $ \ rec_clas -> -- Only name generation inside loop
do { traceIf (text "buildClass")
; tc_rep_name <- newTyConRepName tycon_name
; let univ_bndrs = tyConTyVarBinders binders
univ_tvs = binderVars univ_bndrs
tycon = mkClassTyCon tycon_name binders roles
AbstractTyCon rec_clas tc_rep_name
result = mkAbstractClass tycon_name univ_tvs fds tycon
; traceIf (text "buildClass" <+> ppr tycon)
; return result }
buildClass tycon_name binders roles fds
(Just (sc_theta, at_items, sig_stuff, mindef))
= fixM $ \ rec_clas -> -- Only name generation inside loop
do { traceIf (text "buildClass")
; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc
; tc_rep_name <- newTyConRepName tycon_name
; op_items <- mapM (mk_op_item rec_clas) sig_stuff
-- Build the selector id and default method id
-- Make selectors for the superclasses
; sc_sel_names <- mapM (newImplicitBinder tycon_name . mkSuperDictSelOcc)
(takeList sc_theta [fIRST_TAG..])
; let sc_sel_ids = [ mkDictSelId sc_name rec_clas
| sc_name <- sc_sel_names]
-- We number off the Dict superclass selectors, 1, 2, 3 etc so that we
-- can construct names for the selectors. Thus
-- class (C a, C b) => D a b where ...
-- gives superclass selectors
-- D_sc1, D_sc2
-- (We used to call them D_C, but now we can have two different
-- superclasses both called C!)
; let use_newtype = isSingleton arg_tys
-- Use a newtype if the data constructor
-- (a) has exactly one value field
-- i.e. exactly one operation or superclass taken together
-- (b) that value is of lifted type (which they always are, because
-- we box equality superclasses)
-- See note [Class newtypes and equality predicates]
-- We treat the dictionary superclasses as ordinary arguments.
-- 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
univ_bndrs = tyConTyVarBinders binders
univ_tvs = binderVars univ_bndrs
; rep_nm <- newTyConRepName datacon_name
; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
datacon_name
False -- Not declared infix
rep_nm
(map (const no_bang) args)
(Just (map (const HsLazy) args))
[{- No fields -}]
univ_tvs
[{- no existentials -}]
univ_bndrs
[{- No GADT equalities -}]
[{- No theta -}]
arg_tys
(mkTyConApp rec_tycon (mkTyVarTys univ_tvs))
rec_tycon
(mkTyConTagMap rec_tycon)
; rhs <- case () of
_ | use_newtype
-> mkNewTyConRhs tycon_name rec_tycon dict_con
| isCTupleTyConName tycon_name
-> return (TupleTyCon { data_con = dict_con
, tup_sort = ConstraintTuple })
| otherwise
-> return (mkDataTyConRhs [dict_con])
; let { tycon = mkClassTyCon tycon_name binders roles
rhs rec_clas tc_rep_name
-- A class can be recursive, and in the case of newtypes
-- this matters. For example
-- class C a where { op :: C b => a -> b -> Int }
-- Because C has only one operation, it is represented by
-- a newtype, and it should be a *recursive* newtype.
-- [If we don't make it a recursive newtype, we'll expand the
-- newtype like a synonym, but that will lead to an infinite
-- type]
; result = mkClass tycon_name univ_tvs fds
sc_theta sc_sel_ids at_items
op_items mindef tycon
}
; traceIf (text "buildClass" <+> ppr tycon)
; return result }
where
no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
mk_op_item rec_clas (op_name, _, dm_spec)
= do { dm_info <- mk_dm_info op_name dm_spec
; return (mkDictSelId op_name rec_clas, dm_info) }
mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type))
-> TcRnIf n m (Maybe (Name, DefMethSpec Type))
mk_dm_info _ Nothing
= return Nothing
mk_dm_info op_name (Just VanillaDM)
= do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc
; return (Just (dm_name, VanillaDM)) }
mk_dm_info op_name (Just (GenericDM (loc, dm_ty)))
= do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc
; return (Just (dm_name, GenericDM dm_ty)) }
{-
Note [Class newtypes and equality predicates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
class (a ~ F b) => C a b where
op :: a -> b
We cannot represent this by a newtype, even though it's not
existential, because there are two value fields (the equality
predicate and op. See Trac #2238
Moreover,
class (a ~ F b) => C a b where {}
Here we can't use a newtype either, even though there is only
one field, because equality predicates are unboxed, and classes
are boxed.
-}
newImplicitBinder :: Name -- Base name
-> (OccName -> OccName) -- Occurrence name modifier
-> TcRnIf m n Name -- Implicit name
-- Called in BuildTyCl to allocate the implicit binders of type/class decls
-- For source type/class decls, this is the first occurrence
-- For iface ones, the LoadIface has already allocated a suitable name in the cache
newImplicitBinder base_name mk_sys_occ
= newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name)
newImplicitBinderLoc :: Name -- Base name
-> (OccName -> OccName) -- Occurrence name modifier
-> SrcSpan
-> TcRnIf m n Name -- Implicit name
-- Just the same, but lets you specify the SrcSpan
newImplicitBinderLoc base_name mk_sys_occ loc
| Just mod <- nameModule_maybe base_name
= newGlobalBinder mod occ loc
| otherwise -- When typechecking a [d| decl bracket |],
-- TH generates types, classes etc with Internal names,
-- so we follow suit for the implicit binders
= do { uniq <- newUnique
; return (mkInternalName uniq occ loc) }
where
occ = mk_sys_occ (nameOccName base_name)
-- | Make the 'TyConRepName' for this 'TyCon'
newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName
newTyConRepName tc_name
| Just mod <- nameModule_maybe tc_name
, (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)
= newGlobalBinder mod occ noSrcSpan
| otherwise
= newImplicitBinder tc_name mkTyConRepOcc